taffybar 0.2.1 → 0.3.0

raw patch · 33 files changed

+1986/−342 lines, 33 filesdep +X11dep +dbusdep +splitdep −dbus-coredep −web-encodings

Dependencies added: X11, dbus, split, stm, transformers

Dependencies removed: dbus-core, web-encodings

Files

• README.md +1/−2
• src/System/Information/Battery.hs +19/−16
• src/System/Information/CPU2.hs +22/−1
• src/System/Information/DiskIO.hs +35/−0
• src/System/Information/EWMHDesktopInfo.hs +119/−0
• src/System/Information/Network.hs +20/−1
• src/System/Information/StreamInfo.hs +45/−7
• src/System/Information/X11DesktopInfo.hs +205/−0
• src/System/Taffybar.hs +4/−2
• src/System/Taffybar/Battery.hs +24/−8
• src/System/Taffybar/CPUMonitor.hs +38/−0
• src/System/Taffybar/DiskIOMonitor.hs +37/−0
• src/System/Taffybar/FSMonitor.hs +29/−9
• src/System/Taffybar/FreedesktopNotifications.hs +165/−193
• src/System/Taffybar/Hooks/PagerHints.hs +116/−0
• src/System/Taffybar/LayoutSwitcher.hs +105/−0
• src/System/Taffybar/MPRIS.hs +10/−14
• src/System/Taffybar/MPRIS2.hs +116/−0
• src/System/Taffybar/NetMonitor.hs +35/−10
• src/System/Taffybar/Pager.hs +153/−0
• src/System/Taffybar/SimpleClock.hs +60/−39
• src/System/Taffybar/Systray.hs +1/−1
• src/System/Taffybar/TaffyPager.hs +94/−0
• src/System/Taffybar/Weather.hs +21/−7
• src/System/Taffybar/Widgets/Graph.hs +12/−1
• src/System/Taffybar/Widgets/PollingGraph.hs +1/−0
• src/System/Taffybar/Widgets/PollingLabel.hs +2/−4
• src/System/Taffybar/Widgets/Util.hs +62/−0
• src/System/Taffybar/Widgets/VerticalBar.hs +6/−8
• src/System/Taffybar/WindowSwitcher.hs +169/−0
• src/System/Taffybar/WorkspaceSwitcher.hs +214/−0
• src/System/Taffybar/XMonadLog.hs +9/−12
• taffybar.cabal +37/−7

@@ -22,7 +22,7 @@  * Battery widget  * Textual clock  * Freedesktop.org notifications (via dbus)- * MPRIS widget (currently only supports MPRIS1)+ * MPRIS1 and MPRIS2 widgets  * Weather widget  * XMonad log widget (listens on dbus instead of stdin)  * System tray@@ -33,6 +33,5 @@ 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

@@ -19,12 +19,14 @@ import Data.Maybe import Data.Word import Data.Int-import DBus.Client.Simple-import Data.List ( find )-import Data.Text ( isInfixOf, Text )+import DBus+import DBus.Client+import Data.List ( find, isInfixOf )+import Data.Text ( Text )+import qualified Data.Text as T  -- | An opaque wrapper around some internal library state-newtype BatteryContext = BC Proxy+data BatteryContext = BC Client ObjectPath  data BatteryType = BatteryTypeUnknown                  | BatteryTypeLinePower@@ -90,7 +92,7 @@ -- | 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)+firstBattery = find (isInfixOf "BAT" . formatObjectPath)  -- | The name of the power daemon bus powerBusName :: BusName@@ -128,16 +130,16 @@ -- 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+getBatteryInfo (BC systemConn battPath) = 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]+  reply <- call_ systemConn (methodCall battPath "org.freedesktop.DBus.Properties" "GetAll")+                             { methodCallDestination = Just "org.freedesktop.UPower"+                             , methodCallBody = [toVariant $ T.pack "org.freedesktop.UPower.Device"]+                             }    let dict :: Map Text Variant-      Just dict = fromVariant val+      Just dict = fromVariant (methodReturnBody reply !! 0)   return BatteryInfo { batteryNativePath = readDict dict "NativePath" ""                      , batteryVendor = readDict dict "Vendor" ""                      , batteryModel = readDict dict "Model" ""@@ -173,11 +175,12 @@    -- 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+  reply <- call_ systemConn (methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices")+        { methodCallDestination = Just powerBusName+        }+  let Just powerDevices = fromVariant (methodReturnBody reply !! 0)+   case firstBattery powerDevices of     Nothing -> return Nothing     Just battPath ->-      proxy systemConn powerBusName battPath >>= (return . Just . BC)-+      return . Just $ BC systemConn battPath

@@ -1,12 +1,33 @@-module System.Information.CPU2 (getCPULoad) where+-----------------------------------------------------------------------------+-- |+-- Module      : System.Information.CPU2+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Provides information about used CPU times, obtained from parsing the+-- @\/proc\/stat@ file using some of the facilities included in the+-- "System.Information.StreamInfo" module.+--+----------------------------------------------------------------------------- +module System.Information.CPU2 (getCPULoad, getCPUInfo) where+ import System.Information.StreamInfo (getLoad, getParsedInfo) +-- | Returns a two-element list containing relative system and user times+-- calculated using two almost simultaneous samples of the @\/proc\/stat@ file+-- for the given core (or all of them aggregated, if \"cpu\" is passed). getCPULoad :: String -> IO [Double] getCPULoad cpu = do     load <- getLoad 0.05 $ getCPUInfo cpu     return [load!!0 + load!!1, load!!2] +-- | Returns a list of 5 to 7 elements containing all the values available for+-- the given core (or all of them aggregated, if "cpu" is passed). getCPUInfo :: String -> IO [Integer] getCPUInfo = getParsedInfo "/proc/stat" parse 

@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Information.DiskIO+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Provides information about read/write operations in a given disk or+-- partition, obtained from parsing the @\/proc\/diskstats@ file with some+-- of the facilities included in the "System.Information.StreamInfo" module.+-----------------------------------------------------------------------------++module System.Information.DiskIO (getDiskTransfer) where++import System.Information.StreamInfo (getParsedInfo, getTransfer)++-- | Returns a two-element list containing the speed of transfer for read and+-- write operations performed in the given disk\/partition (e.g. \"sda\",+-- \"sda1\").+getDiskTransfer :: String -> IO [Double]+getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk++-- | Returns the list of all the values available in @\/proc\/diskstats@+-- for the given disk or partition.+getDiskInfo :: String -> IO [Integer]+getDiskInfo = getParsedInfo "/proc/diskstats" parse++parse :: String -> [(String, [Integer])]+parse = map tuplize . map (drop 2 . words) . lines++tuplize :: [String] -> (String, [Integer])+tuplize s = (head s, map read [s!!3, s!!7])

@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Information.EWMHDesktopInfo+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Functions to access data provided by the X11 desktop via EWHM hints. This+-- module requires that the EwmhDesktops hook from the XMonadContrib project+-- be installed in your @~\/.xmonad\/xmonad.hs@ configuration:+--+-- > import XMonad+-- > import XMonad.Hooks.EwmhDesktops (ewmh)+-- >+-- > main = xmonad $ ewmh $ ...+--+-----------------------------------------------------------------------------++module System.Information.EWMHDesktopInfo+  ( X11Window      -- re-exported from X11DesktopInfo+  , withDefaultCtx -- re-exported from X11DesktopInfo+  , isWindowUrgent -- re-exported from X11DesktopInfo+  , getCurrentWorkspace+  , getVisibleWorkspaces+  , getWorkspaceNames+  , switchToWorkspace+  , getWindowTitle+  , getWindowClass+  , getActiveWindowTitle+  , getWindows+  , getWindowHandles+  , getWorkspace+  , focusWindow+  ) where++import Data.List (elemIndex)+import Data.Maybe (listToMaybe, mapMaybe)+import System.Information.X11DesktopInfo++noFocus :: String+noFocus = "..."++-- | Retrieve the index of the current workspace in the desktop,+-- starting from 0.+getCurrentWorkspace :: X11Property Int+getCurrentWorkspace = readAsInt Nothing "_NET_CURRENT_DESKTOP"++-- | Retrieve the indexes of all currently visible workspaces+-- with the active workspace at the head of the list.+getVisibleWorkspaces :: X11Property [Int]+getVisibleWorkspaces = do+  vis <- getVisibleTags+  allNames <- getWorkspaceNames+  cur <- getCurrentWorkspace+  return $ cur : mapMaybe (`elemIndex` allNames) vis++-- | Return a list with the names of all the workspaces currently+-- available.+getWorkspaceNames :: X11Property [String]+getWorkspaceNames = readAsListOfString Nothing "_NET_DESKTOP_NAMES"++-- | Ask the window manager to switch to the workspace with the given+-- index, starting from 0.+switchToWorkspace :: Int -> X11Property ()+switchToWorkspace idx = do+  cmd <- getAtom "_NET_CURRENT_DESKTOP"+  sendCommandEvent cmd (fromIntegral idx)++-- | Get the title of the given X11 window.+getWindowTitle :: X11Window -> X11Property String+getWindowTitle window = do+  let w = Just window+  prop <- readAsString w "_NET_WM_NAME"+  case prop of+    "" -> readAsString w "WM_NAME"+    _  -> return prop++-- | Get the class of the given X11 window.+getWindowClass :: X11Window -> X11Property String+getWindowClass window = readAsString (Just window) "WM_CLASS"++withActiveWindow :: (X11Window -> X11Property String) -> X11Property String+withActiveWindow getProp = do+  awt <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"+  let w = listToMaybe $ filter (>0) awt+  maybe (return noFocus) getProp w++-- | Get the title of the currently focused window.+getActiveWindowTitle :: X11Property String+getActiveWindowTitle = withActiveWindow getWindowTitle++-- | Return a list of all windows+getWindows :: X11Property [X11Window]+getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST"++-- | Return a list of pairs of (props, window) for all the windows open.+-- props is a pair of (window title, window class),+-- and window is the internal ID of one window.+getWindowHandles :: X11Property [((Int, String, String), X11Window)]+getWindowHandles = do+  windows <- getWindows+  workspaces <- mapM getWorkspace windows+  wtitles <- mapM getWindowTitle windows+  wclasses <- mapM getWindowClass windows+  return $ zip (zip3 workspaces wtitles wclasses) windows++-- | Return the index (starting from 0) of the workspace on which the+-- given window is being displayed.+getWorkspace :: X11Window -> X11Property Int+getWorkspace window = readAsInt (Just window) "_NET_WM_DESKTOP"++-- | Ask the window manager to give focus to the given window.+focusWindow :: X11Window -> X11Property ()+focusWindow wh = do+  cmd <- getAtom "_NET_ACTIVE_WINDOW"+  sendWindowEvent cmd (fromIntegral wh)

@@ -1,7 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Information.Network+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Provides information about network traffic over selected interfaces,+-- obtained from parsing the @\/proc\/net\/dev@ file using some of the+-- facilities provided by the "System.Information.StreamInfo" module.+--+-----------------------------------------------------------------------------+ module System.Information.Network (getNetInfo) where  import System.Information.StreamInfo (getParsedInfo) +-- | Returns a two-element list containing the current number of bytes+-- received and transmitted via the given network interface (e.g. \"wlan0\"),+-- according to the contents of the @\/proc\/dev\/net@ file. getNetInfo :: String -> IO [Integer] getNetInfo = getParsedInfo "/proc/net/dev" parse @@ -10,4 +29,4 @@  tuplize :: [String] -> (String, [Integer]) tuplize s = (init $ head s, map read [s!!1, s!!out])-    where out = (length s) - 7+    where out = (length s) - 8

@@ -1,14 +1,30 @@--- | Generic code to poll any of the many data files maintained by the kernel in+--------------------------------------------------------------------------------+-- |+-- Module      : System.Information.StreamInfo+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Generic code to poll any of the many data files maintained by the kernel in -- POSIX systems. Provides methods for applying a custom parsing function to the -- contents of the file and to calculate differentials across one or more values -- provided via the file.+--+--------------------------------------------------------------------------------+ module System.Information.StreamInfo     ( getParsedInfo     , getLoad-    , getTransfer) where+    , getAccLoad+    , getTransfer+    ) where  import Control.Concurrent (threadDelay)-import Data.Maybe (fromJust)+import Data.IORef+import Data.Maybe ( fromMaybe )  -- | Apply the given parser function to the file under the given path to produce -- a lookup map, then use the given selector as key to extract from it the@@ -17,13 +33,20 @@ getParsedInfo path parser selector = do     file <- readFile path     (length file) `seq` return ()-    return (fromJust $ lookup selector $ parser file)+    return (fromMaybe [] $ lookup selector $ parser file)  truncVal :: Double -> Double truncVal v   | isNaN v || v < 0.0 = 0.0   | otherwise = v +-- | Convert the given list of Integer to a list of the ratios of each of its+-- elements against their sum.+toRatioList :: [Integer] -> [Double]+toRatioList deltas = map truncVal ratios+    where total = fromIntegral $ foldr (+) 0 deltas+          ratios = map ((/total) . fromIntegral) deltas+ -- | Execute the given action twice with the given delay in-between and return -- the difference between the two samples. probe :: IO [Integer] -> Double -> IO [Integer]@@ -33,6 +56,15 @@     b <- action     return $ zipWith (-) b a +-- | Execute the given action once and return the difference between the+-- obtained sample and the one contained in the given IORef.+accProbe :: IO [Integer] -> IORef [Integer] -> IO [Integer]+accProbe action sample = do+    a <- readIORef sample+    b <- action+    writeIORef sample b+    return $ zipWith (-) b a+ -- | Probe the given action and, interpreting the result as a variation in time, -- return the speed of change of its values. getTransfer :: Double -> IO [Integer] -> IO [Double]@@ -46,7 +78,13 @@ getLoad :: Double -> IO [Integer] -> IO [Double]  getLoad interval action = do     deltas <- probe action interval-    let total  = fromIntegral $ foldr (+) 0 deltas-        ratios = map ((/total) . fromIntegral) deltas-    return $ map truncVal ratios+    return $ toRatioList deltas++-- | Similar to getLoad, but execute the given action only once and use the+-- given IORef to calculate the result and to save the current value, so it+-- can be reused in the next call.+getAccLoad :: IORef [Integer] -> IO [Integer] -> IO [Double]+getAccLoad sample action = do+     deltas <- accProbe action sample+     return $ toRatioList deltas 

@@ -0,0 +1,205 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Information.X11DesktopInfo+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Low-level functions to access data provided by the X11 desktop via window+-- properties. One of them ('getVisibleTags') depends on the PagerHints hook+-- being installed in your @~\/.xmonad\/xmonad.hs@ configuration:+--+-- > import System.Taffybar.Hooks.PagerHints (pagerHints)+-- >+-- > main = xmonad $ ewmh $ pagerHints $ ...+--+-----------------------------------------------------------------------------++module System.Information.X11DesktopInfo+  ( X11Context+  , X11Property+  , X11Window+  , withDefaultCtx+  , readAsInt+  , readAsString+  , readAsListOfString+  , readAsListOfWindow+  , isWindowUrgent+  , getVisibleTags+  , getAtom+  , eventLoop+  , sendCommandEvent+  , sendWindowEvent+  ) where++import Codec.Binary.UTF8.String as UTF8+import Control.Monad.Reader+import Data.Bits (testBit, (.|.))+import Data.List.Split (endBy)+import Data.Maybe (fromMaybe)+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras++data X11Context = X11Context { contextDisplay :: Display, contextRoot :: Window }+type X11Property a = ReaderT X11Context IO a+type X11Window = Window+type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])++-- | Put the current display and root window objects inside a Reader+-- transformer for further computation.+withDefaultCtx :: X11Property a -> IO a+withDefaultCtx fun = do+  ctx <- getDefaultCtx+  res <- runReaderT fun ctx+  closeDisplay (contextDisplay ctx)+  return res++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a value of type Int. If that+-- property hasn't been set, then return -1.+readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+          -> String -- ^ name of the property to retrieve+          -> X11Property Int+readAsInt window name = do+  prop <- fetch getWindowProperty32 window name+  case prop of+    Just (x:_) -> return (fromIntegral x)+    _          -> return (-1)++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a String. If the property+-- hasn't been set, then return an empty string.+readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+             -> String          -- ^ name of the property to retrieve+             -> X11Property String+readAsString window name = do+  prop <- fetch getWindowProperty8 window name+  case prop of+    Just xs -> return . UTF8.decode . map fromIntegral $ xs+    _       -> return []++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a list of Strings. If the+-- property hasn't been set, then return an empty list.+readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+                   -> String          -- ^ name of the property to retrieve+                   -> X11Property [String]+readAsListOfString window name = do+  prop <- fetch getWindowProperty8 window name+  case prop of+    Just xs -> return (parse xs)+    _       -> return []+  where+    parse = endBy "\0" . UTF8.decode . map fromIntegral++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a list of X11 Window IDs. If+-- the property hasn't been set, then return an empty list.+readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+                   -> String          -- ^ name of the property to retrieve+                   -> X11Property [X11Window]+readAsListOfWindow window name = do+  prop <- fetch getWindowProperty32 window name+  case prop of+    Just xs -> return $ map fromIntegral xs+    _       -> return []++-- | Determine whether the \"urgent\" flag is set in the WM_HINTS of+-- the given window.+isWindowUrgent :: X11Window -> X11Property Bool+isWindowUrgent window = do+  hints <- fetchWindowHints window+  return $ testBit (wmh_flags hints) urgencyHintBit++-- | Retrieve the value of the special _XMONAD_VISIBLE_WORKSPACES hint set+-- by the PagerHints hook provided by Taffybar (see module documentation for+-- instructions on how to do this), or an empty list of strings if the+-- PagerHints hook is not available.+getVisibleTags :: X11Property [String]+getVisibleTags = return =<<+  readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"++-- | Return the Atom with the given name.+getAtom :: String -> X11Property Atom+getAtom s = do+  (X11Context d _) <- ask+  atom <- liftIO $ internAtom d s False+  return atom++-- | Spawn a new thread and listen inside it to all incoming events,+-- invoking the given function to every event of type @MapNotifyEvent@ that+-- arrives, and subscribing to all events of this type emitted by newly+-- created windows.+eventLoop :: (Event -> IO ()) -> X11Property ()+eventLoop dispatch = do+  (X11Context d w) <- ask+  liftIO $ do+    xSetErrorHandler+    selectInput d w $ propertyChangeMask .|. substructureNotifyMask+    allocaXEvent $ \e -> forever $ do+      event <- nextEvent d e >> getEvent e+      case event of+        MapNotifyEvent _ _ _ _ _ window _ -> do+          selectInput d window propertyChangeMask+        _ -> return ()+      dispatch event++-- | Emit a \"command\" event with one argument for the X server. This is+-- used to send events that can be received by event hooks in the XMonad+-- process and acted upon in that context.+sendCommandEvent :: Atom -> Atom -> X11Property ()+sendCommandEvent cmd arg = do+  (X11Context dpy root) <- ask+  sendCustomEvent dpy cmd arg root root++-- | Similar to 'sendCommandEvent', but with an argument of type Window.+sendWindowEvent :: Atom -> X11Window -> X11Property ()+sendWindowEvent cmd win = do+  (X11Context dpy root) <- ask+  sendCustomEvent dpy cmd cmd root win++-- | Build a new X11Context containing the current X11 display and its root+-- window.+getDefaultCtx :: IO X11Context+getDefaultCtx = do+  d <- openDisplay ""+  w <- rootWindow d $ defaultScreen d+  return $ X11Context d w++-- | Apply the given function to the given window in order to obtain the X11+-- property with the given name, or Nothing if no such property can be read.+fetch :: (Integral a)+      => PropertyFetcher a -- ^ Function to use to retrieve the property.+      -> Maybe X11Window   -- ^ Window to read from. Nothing means the root Window.+      -> String            -- ^ Name of the property to retrieve.+      -> X11Property (Maybe [a])+fetch fetcher window name = do+  (X11Context dpy root) <- ask+  atom <- getAtom name+  prop <- liftIO $ fetcher dpy atom (fromMaybe root window)+  return prop++-- | Retrieve the @WM_HINTS@ mask assigned by the X server to the given window.+fetchWindowHints :: X11Window -> X11Property WMHints+fetchWindowHints window = do+  (X11Context d _) <- ask+  hints <- liftIO $ getWMHints d window+  return hints++-- | Emit an event of type @ClientMessage@ that can be listened to and+-- consumed by XMonad event hooks.+sendCustomEvent :: Display+                -> Atom+                -> Atom+                -> X11Window+                -> X11Window+                -> X11Property ()+sendCustomEvent dpy cmd arg root win = do+  liftIO $ allocaXEvent $ \e -> do+    setEventType e clientMessage+    setClientMessageEvent e win cmd 32 arg currentTime+    sendEvent dpy root False structureNotifyMask e+    sync dpy False

@@ -80,7 +80,7 @@   --   -- > import XMonad.Hooks.DynamicLog   -- > import XMonad.Hooks.ManageDocks-  -- > import DBus.Client.Simple+  -- > import DBus.Client   -- > import System.Taffybar.XMonadLog ( dbusLog )   -- >   -- > main = do@@ -159,6 +159,7 @@                  , 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)+                 , widgetSpacing :: Int -- ^ The number of pixels between widgets                  , 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@@ -171,6 +172,7 @@                  , monitorNumber = 0                  , barHeight = 25                  , barPosition = Top+                 , widgetSpacing = 10                  , errorMsg = Nothing                  , startWidgets = []                  , endWidgets = []@@ -241,7 +243,7 @@                                               (barHeight cfg)                                               monitorSize                                               allMonitorSizes-  box <- hBoxNew False 10+  box <- hBoxNew False $ widgetSpacing cfg   containerAdd window box    mapM_ (\io -> do

@@ -12,8 +12,10 @@   defaultBatteryConfig   ) where +import Data.Int import Graphics.UI.Gtk import Text.Printf+import Text.StringTemplate  import System.Information.Battery import System.Taffybar.Widgets.PollingBar@@ -24,16 +26,30 @@   info <- getBatteryInfo ctxt   let battPctNum :: Int       battPctNum = floor (batteryPercentage info)-  return $ printf fmt battPctNum+      formatTime :: Int64 -> String+      formatTime seconds =+        let minutes = seconds `div` 60+            hours = minutes `div` 60+            minutes' = minutes `mod` 60+        in printf "%02d:%02d" hours minutes' +      battTime :: String+      battTime = case (batteryState info) of+        BatteryStateCharging -> (formatTime $ batteryTimeToFull info)+        BatteryStateDischarging -> (formatTime $ batteryTimeToEmpty info)+        _ -> "-"++      tpl = newSTMP fmt+      tpl' = setManyAttrib [ ("percentage", show battPctNum)+                           , ("time", battTime)+                           ] tpl+  return $ render tpl'+ -- | 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.+-- specified format string where $percentage$ is replaced with the+-- percentage of battery remaining and $time$ is replaced with the+-- time until the battery is fully charged/discharged. textBatteryNew :: String    -- ^ Display format                   -> Double -- ^ Poll period in seconds                   -> IO Widget@@ -85,7 +101,7 @@       --       -- Converting it to combine the two shouldn't be hard.       b <- hBoxNew False 1-      txt <- textBatteryNew "%d%%" pollSeconds+      txt <- textBatteryNew "$percentage$%" pollSeconds       bar <- pollingBarNew battCfg pollSeconds (battPct ctxt)       boxPackStart b bar PackNatural 0       boxPackStart b txt PackNatural 0

@@ -0,0 +1,38 @@+--------------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.CPUMonitor+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple CPU monitor that uses a PollingGraph to visualize variations in the+-- user and system CPU times in one selected core, or in all cores available.+--+--------------------------------------------------------------------------------+module System.Taffybar.CPUMonitor where++import Data.IORef+import Graphics.UI.Gtk+import System.Information.CPU2 (getCPUInfo)+import System.Information.StreamInfo (getAccLoad)+import System.Taffybar.Widgets.PollingGraph++-- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to+-- getCPUInfo, associated to an IORef used to remember the values yielded by the+-- last call to this function.+cpuMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.+              -> Double      -- ^ Polling period (in seconds).+              -> String      -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").+              -> IO Widget+cpuMonitorNew cfg interval cpu = do+    info <- getCPUInfo cpu+    sample <- newIORef info+    pollingGraphNew cfg interval $ probe sample cpu++probe :: IORef [Integer] -> String -> IO [Double]+probe sample cpuName = do+    load <- getAccLoad sample $ getCPUInfo cpuName+    return [load!!0 + load!!1, load!!2] -- user, system

@@ -0,0 +1,37 @@+--------------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.DiskIOMonitor+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple Disk IO monitor that uses a PollingGraph to visualize the speed of+-- read/write operations in one selected disk or partition.+--+--------------------------------------------------------------------------------++module System.Taffybar.DiskIOMonitor ( dioMonitorNew ) where++import Graphics.UI.Gtk+import System.Information.DiskIO (getDiskTransfer)+import System.Taffybar.Widgets.PollingGraph++-- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by+-- regular calls to 'getDiskTransfer'. The results of calling this function+-- are normalized to the maximum value of the obtained probe (either read or+-- write transfer).+dioMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.+              -> Double      -- ^ Polling period (in seconds).+              -> String      -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").+              -> IO Widget+dioMonitorNew cfg pollSeconds =+  pollingGraphNew cfg pollSeconds . probeDisk++probeDisk :: String -> IO [Double]+probeDisk disk = do+  transfer <- getDiskTransfer disk+  let top = foldr max 1.0 transfer+  return $ map (/top) transfer

@@ -1,18 +1,38 @@-module System.Taffybar.FSMonitor where+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.FSMonitor+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple text widget that monitors the current usage of selected disk+-- partitions by regularly parsing the output of the df command in Linux+-- systems.+--+----------------------------------------------------------------------------- +module System.Taffybar.FSMonitor ( fsMonitorNew ) where+ import Graphics.UI.Gtk import System.Process (readProcess) import System.Taffybar.Widgets.PollingLabel-import Text.Printf (printf) -fsMonitorNew :: Double -> [String] -> IO Widget+-- | Creates a new filesystem monitor widget. It contains one 'PollingLabel'+-- that displays the data returned by the df command. The usage level of all+-- requested partitions is extracted in one single operation.+fsMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 500)+             -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])+             -> IO Widget fsMonitorNew interval fsList = do     label <- pollingLabelNew "" interval $ showFSInfo fsList     widgetShowAll label     return $ toWidget label-    where-        showFSInfo :: [String] -> IO String-        showFSInfo fsDict = do-            fsOut <- readProcess "df" (["-kP"] ++ fsList) ""-            let fss = map ((take 2) . reverse . words) $ drop 1 $ lines fsOut-            return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss++showFSInfo :: [String] -> IO String+showFSInfo fsList = do+  fsOut <- readProcess "df" (["-kP"] ++ fsList) ""+  let fss = map ((take 2) . reverse . words) $ drop 1 $ lines fsOut+  return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss

@@ -16,9 +16,10 @@   ) where  import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad ( forever ) import Control.Monad.Trans ( liftIO ) import Data.Int ( Int32 )-import Data.IORef import Data.Map ( Map ) import Data.Monoid ( mconcat ) import qualified Data.Sequence as S@@ -26,9 +27,9 @@ import Data.Text ( Text ) import qualified Data.Text as T import Data.Word ( Word32 )-import DBus.Client.Simple+import DBus+import DBus.Client import Graphics.UI.Gtk hiding ( Variant )-import Web.Encodings ( decodeHtml, encodeHtml )  -- | A simple structure representing a Freedesktop notification data Notification = Notification { noteAppName :: Text@@ -40,33 +41,33 @@                                  }                     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+data NotifyState = NotifyState { noteWidget :: Label                                , noteContainer :: Widget-                               , noteTimerThread :: MVar (Maybe ThreadId)                                , noteConfig :: NotificationConfig+                               , noteQueue :: TVar (Seq Notification)+                                 -- ^ The queue of active (but not yet+                                 -- displayed) notifications+                               , noteIdSource :: TVar Word32+                                 -- ^ A source of new notification ids+                               , noteCurrent :: TVar (Maybe Notification)+                                 -- ^ The current note being displayed+                               , noteChan :: Chan ()+                                 -- ^ Wakes up the GUI update thread                                }  initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState initialNoteState wrapper l cfg = do-  c <- newChan-  m <- newMVar 1-  q <- newMVar S.empty-  t <- newMVar Nothing+  m <- newTVarIO 1+  q <- newTVarIO S.empty+  c <- newTVarIO Nothing+  ch <- newChan   return NotifyState { noteQueue = q                      , noteIdSource = m-                     , noteWorkerChan = c                      , noteWidget = l                      , noteContainer = wrapper-                     , noteTimerThread = t+                     , noteCurrent = c                      , noteConfig = cfg+                     , noteChan = ch                      }  getServerInformation :: IO (Text, Text, Text, Text)@@ -79,12 +80,34 @@ getCapabilities :: IO [Text] getCapabilities = return ["body", "body-markup"] +nextNotification :: NotifyState -> STM ()+nextNotification s = do+  q <- readTVar (noteQueue s)+  case viewl q of+    EmptyL -> do+      writeTVar (noteCurrent s) Nothing+    next :< rest -> do+      writeTVar (noteQueue s) rest+      writeTVar (noteCurrent s) (Just next)++-- | Filter any notifications with this id from the current queue.  If+-- it is the current notification, replace it with the next, if any. 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))+  atomically $ do+    modifyTVar' (noteQueue istate) removeNote+    curNote <- readTVar (noteCurrent istate)+    case curNote of+      Nothing -> return ()+      Just cnote+        | noteId cnote /= nid -> return ()+        | otherwise ->+          -- in this case, the note was current so we take the next,+          -- if any+          nextNotification istate+  wakeupDisplayThread istate+  where+    removeNote = S.filter (\n -> noteId n /= nid)  -- | Apply the user's formatter and truncate the result with the -- specified maxlen.@@ -94,8 +117,24 @@     maxlen = notificationMaxLength $ noteConfig s     fmt = notificationFormatter $ noteConfig s -notify :: MVar Int-          -> NotifyState+-- | The notificationDaemon thread looks at the notification queue.+-- If the queue is empty and there is no current message, it sets the+-- new message as the current message in a TVar (Just Notification)+-- and displays the message itself and sets up a thread to remove the+-- message after its timeout.+--+-- If there is a current message, add the new message to the queue.+--+-- The timeout thread just sleeps for its timeout and then atomically+-- replaces the current message with the next one from the queue.  It+-- then displays the new current message.  However, if the current+-- message has changed (because of a user cancellation), the timer+-- thread just exits.+--+-- User cancellation atomically reads (and replaces) the current+-- notification (if there is another in the queue).  If it found a new+-- notification, that node is then displayed.+notify :: NotifyState           -> Text -- ^ Application name           -> Word32 -- ^ Replaces id           -> Text -- ^ App icon@@ -105,167 +144,100 @@           -> 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+notify istate appName replaceId _ summary body _ _ timeout = do+  nid <- atomically $ do+    tid <- readTVar idsrc+    modifyTVar' idsrc (+1)+    return tid+  let realId = if replaceId == 0 then fromIntegral nid else replaceId+      n = Notification { noteAppName = appName+                       , noteReplaceId = replaceId+                       , noteSummary = escapeText summary+                       , noteBody = escapeText body+                       , noteExpireTimeout = tout+                       , noteId = realId+                       }+  -- If we are replacing an existing note, atomically do the swap in+  -- the note queue and then make this the new current if the queue is+  -- empty OR if the current has this id.+  dn <- atomically $ do+    modifyTVar' (noteQueue istate) (replaceNote n)+    cnote <- readTVar (noteCurrent istate)+    case cnote of+      Nothing -> do+        writeTVar (noteCurrent istate) (Just n)+        return (Just n)+      Just curNote+        | noteId curNote == realId -> do+          writeTVar (noteCurrent istate) (Just n)+          return (Just n)+        | otherwise -> do+          modifyTVar' (noteQueue istate) (|>n)+          return Nothing+  -- This is a little gross - if we added the new notification to the+  -- queue, we can't call displayNote on it because that will+  -- obliterate the current active notification.+  case dn of+    -- take no action; timeout threads will handle it+    Nothing -> return ()+    Just _ -> wakeupDisplayThread istate+  return realId+  where+    replaceNote newNote = fmap (\n -> if noteId n == noteReplaceId newNote then newNote else n)+    idsrc = noteIdSource istate+    escapeText = T.pack . escapeMarkup . T.unpack+    maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate)+    tout = case timeout of+      0 -> maxtout+      (-1) -> maxtout+      _ -> min maxtout timeout +notificationDaemon :: (AutoMethod f1, AutoMethod f2)+                      => f1 -> f2 -> IO () notificationDaemon onNote onCloseNote = do   client <- connectSession-  _ <- requestName client "org.freedesktop.Notifications" [AllowReplacement, ReplaceExisting]+  _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]   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+    [ autoMethod "org.freedesktop.Notifications" "GetServerInformation" getServerInformation+    , autoMethod "org.freedesktop.Notifications" "GetCapabilities" getCapabilities+    , autoMethod "org.freedesktop.Notifications" "CloseNotification" onCloseNote+    , autoMethod "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)+-- | Wakeup the display thread and have it switch out the displayed+-- message for the new current message.+wakeupDisplayThread :: NotifyState -> IO ()+wakeupDisplayThread s = writeChan (noteChan s) () -setExpireTimeout :: Chan WorkType -> Word32 -> Int32 -> IO ()-setExpireTimeout c nid seconds = do-  threadDelay (fromIntegral seconds * 1000000)-  writeChan c (ExpireNote nid)+-- | This thread+displayThread :: NotifyState -> IO ()+displayThread s = forever $ do+  _ <- readChan (noteChan s)+  cur <- atomically $ readTVar (noteCurrent s)+  case cur of+    Nothing -> postGUIAsync (widgetHideAll (noteContainer s))+    Just n -> postGUIAsync $ do+      labelSetMarkup (noteWidget s) (formatMessage s n)+      widgetShowAll (noteContainer s)+      startTimeoutThread s n -userCancel s = do-  liftIO $ writeChan (noteWorkerChan s) (CancelNote Nothing)-  return True+startTimeoutThread :: NotifyState -> Notification -> IO ()+startTimeoutThread s n = do+  _ <- forkIO $ do+    let seconds = noteExpireTimeout n+    threadDelay (fromIntegral seconds * 1000000)+    atomically $ do+      curNote <- readTVar (noteCurrent s)+      case curNote of+        Nothing -> return ()+        Just cnote+          | cnote /= n -> return ()+          | otherwise ->+            -- The note was not invalidated or changed since the timeout+            -- began, so we replace it with the next (if any)+            nextNotification s+    wakeupDisplayThread s+  return ()  data NotificationConfig =   NotificationConfig { notificationMaxTimeout :: Int -- ^ Maximum time that a notification will be displayed (in seconds).  Default: 10@@ -304,16 +276,14 @@   button <- eventBoxNew   sep <- vSeparatorNew -  buttonLabel <- labelNew Nothing-  widgetSetName buttonLabel "NotificationCloseButton"-  buttonStyle <- rcGetStyle buttonLabel-  buttonTextColor <- styleGetText buttonStyle StateNormal-  labelSetMarkup buttonLabel "×"+  bLabel <- labelNew Nothing+  widgetSetName bLabel "NotificationCloseButton"+  labelSetMarkup bLabel "×"    labelSetMaxWidthChars textArea (notificationMaxLength cfg)   labelSetEllipsize textArea EllipsizeEnd -  containerAdd button buttonLabel+  containerAdd button bLabel   boxPackStart box textArea PackGrow 0   boxPackStart box sep PackNatural 0   boxPackStart box button PackNatural 0@@ -324,14 +294,7 @@    istate <- initialNoteState (toWidget frame) textArea cfg   _ <- on button buttonReleaseEvent (userCancel istate)-  _ <- forkIO (workerThread istate) -  -- This is only available to the notify handler, so it doesn't need-  -- to be protected from the worker thread.  There might be multiple-  -- notifiation handler threads, though (not sure), so keep it safe-  -- and use an mvar.-  idSrc <- newMVar 1-   realizableWrapper <- hBoxNew False 0   boxPackStart realizableWrapper frame PackNatural 0   widgetShow realizableWrapper@@ -340,7 +303,16 @@   -- main loop, otherwise things are prone to lock up and block   -- infinitely on an mvar.  Bad stuff - only start the dbus thread   -- after the fake invisible wrapper widget is realized.-  on realizableWrapper realize $ notificationDaemon (notify idSrc istate) (closeNotification istate)+  _ <- on realizableWrapper realize $ do+       _ <- forkIO (displayThread istate)+       notificationDaemon (notify istate) (closeNotification istate) -  -- Don't show ib by default - it will appear when needed+  -- Don't show the widget by default - it will appear when needed   return (toWidget realizableWrapper)+  where+    -- | Close the current note and pull up the next, if any+    userCancel s = do+      liftIO $ do+        atomically $ nextNotification s+        wakeupDisplayThread s+      return True

@@ -0,0 +1,116 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Hooks.PagerHints+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints+-- not contemplated by the EWMH standard:+--+-- [@_XMONAD_CURRENT_LAYOUT@] Contains a UTF-8 string with the name of the+-- windows layout currently used in the active workspace.+--+-- [@_XMONAD_VISIBLE_WORKSPACES@] Contains a list of UTF-8 strings with the+-- names of all the workspaces that are currently showed in a secondary+-- display, or an empty list if in the current installation there's only+-- one monitor.+--+-- The first hint can be set directly on the root window of the default+-- display, or indirectly via X11 events with an atom of the same+-- name. This allows both to track any changes that occur in the layout of+-- the current workspace, as well as to have it changed automatically by+-- just sending a custom event to the hook.+--+-- The second one should be considered read-only, and is set every time+-- XMonad calls its log hooks.+--+-----------------------------------------------------------------------------++module System.Taffybar.Hooks.PagerHints (+  -- * Usage+  -- $usage+  pagerHints+) where++import Codec.Binary.UTF8.String (encode)+import Control.Monad+import Data.Char (ord)+import Data.Monoid+import Foreign.C.Types (CInt)+import XMonad+import qualified XMonad.StackSet as W++-- $usage+--+-- You can use this module with the following in your @xmonad.hs@ file:+--+-- > import System.Taffybar.Hooks.PagerHints (pagerHints)+-- >+-- > main = xmonad $ ewmh $ pagerHints $ defaultConfig+-- > ...++-- | The \"Current Layout\" custom hint.+xLayoutProp :: X Atom+xLayoutProp = return =<< getAtom "_XMONAD_CURRENT_LAYOUT"++-- | The \"Visible Workspaces\" custom hint.+xVisibleProp :: X Atom+xVisibleProp = return =<< getAtom "_XMONAD_VISIBLE_WORKSPACES"++-- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom+-- hints to the given config.+pagerHints :: XConfig a -> XConfig a+pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook+           , logHook = logHook c +++ pagerHintsLogHook }+  where x +++ y = x `mappend` y++-- | Update the current values of both custom hints.+pagerHintsLogHook :: X ()+pagerHintsLogHook = do+  withWindowSet+    (setCurrentLayout . description . W.layout . W.workspace . W.current)+  withWindowSet+    (setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible)++-- | Set the value of the \"Current Layout\" custom hint to the one given.+setCurrentLayout :: String -> X ()+setCurrentLayout l = withDisplay $ \dpy -> do+  r <- asks theRoot+  a <- xLayoutProp+  c <- getAtom "UTF8_STRING"+  let l' = map (fromIntegral . ord) l+  io $ changeProperty8 dpy r a c propModeReplace l'++-- | Set the value of the \"Visible Workspaces\" hint to the one given.+setVisibleWorkspaces :: [String] -> X ()+setVisibleWorkspaces vis = withDisplay $ \dpy -> do+  r  <- asks theRoot+  a  <- xVisibleProp+  c  <- getAtom "UTF8_STRING"+  let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis+  io $ changeProperty8 dpy r a c propModeReplace vis'++-- | Handle all \"Current Layout\" events received from pager widgets, and+-- set the current layout accordingly.+pagerHintsEventHook :: Event -> X All+pagerHintsEventHook (ClientMessageEvent {+    ev_message_type = mt,+    ev_data = d+  }) = withWindowSet $ \_ -> do+  a <- xLayoutProp+  when (mt == a) $ sendLayoutMessage d+  return (All True)+pagerHintsEventHook _ = return (All True)++-- | Request a change in the current layout by sending an internal message+-- to XMonad.+sendLayoutMessage :: [CInt] -> X ()+sendLayoutMessage evData = case evData of+  []   -> return ()+  x:_  -> if x < 0+            then sendMessage FirstLayout+            else sendMessage NextLayout

@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.LayoutSwitcher+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple text widget that shows the XMonad layout used in the currently+-- active workspace, and that allows to change it by clicking with the+-- mouse: left-click to switch to the next layout in the list, right-click+-- to switch to the first one (as configured in @xmonad.hs@)+--+-- N.B. If you're just looking for a drop-in replacement for the+-- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require+-- DBus, you may want to see first "System.Taffybar.TaffyPager".+--+-----------------------------------------------------------------------------++module System.Taffybar.LayoutSwitcher (+  -- * Usage+  -- $usage+  layoutSwitcherNew+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Graphics.UI.Gtk+import Graphics.X11.Xlib.Extras (Event)+import System.Taffybar.Pager+import System.Information.X11DesktopInfo+import System.Taffybar.Widgets.Util++-- $usage+--+-- This widget requires that the "System.Taffybar.Hooks.PagerHints" hook be+-- installed in your @xmonad.hs@:+--+-- > import System.Taffybar.Hooks.PagerHints (pagerHints)+-- > main = do+-- >   xmonad $ ewmh $ pagerHints $ defaultConfig+-- > ...+--+-- Once you've properly configured @xmonad.hs@, you can use the widget in+-- your @taffybar.hs@ file:+--+-- > import System.Taffybar.LayoutSwitcher+-- > main = do+-- >   pager <- pagerNew defaultPagerConfig+-- >   let los = layoutSwitcherNew pager+--+-- now you can use @los@ as any other Taffybar widget.++-- | Name of the X11 events to subscribe, and of the hint to look for for+-- the name of the current layout.+xLayoutProp :: String+xLayoutProp = "_XMONAD_CURRENT_LAYOUT"++-- | Create a new LayoutSwitcher widget that will use the given Pager as+-- its source of events.+layoutSwitcherNew :: Pager -> IO Widget+layoutSwitcherNew pager = do+  label <- labelNew Nothing+  let cfg = config pager+      callback = pagerCallback cfg label+  subscribe pager callback xLayoutProp+  assembleWidget label++-- | Build a suitable callback function that can be registered as Listener+-- of "_XMONAD_CURRENT_LAYOUT" custom events. These events are emitted by+-- the PagerHints hook to notify of changes in the current layout.+pagerCallback :: PagerConfig -> Label -> Event -> IO ()+pagerCallback cfg label _ = do+  layout <- withDefaultCtx $ readAsString Nothing xLayoutProp+  let decorate = activeLayout cfg+  postGUIAsync $ labelSetMarkup label (decorate layout)++-- | Build the graphical representation of the widget.+assembleWidget :: Label -> IO Widget+assembleWidget label = do+  ebox <- eventBoxNew+  containerAdd ebox label+  _ <- on ebox buttonPressEvent dispatchButtonEvent+  widgetShowAll ebox+  return $ toWidget ebox++-- | Call 'switch' with the appropriate argument (1 for left click, -1 for+-- right click), depending on the click event received.+dispatchButtonEvent :: EventM EButton Bool+dispatchButtonEvent = do+  btn <- eventButton+  let trigger = onClick [SingleClick]+  case btn of+    LeftButton  -> trigger $ switch 1+    RightButton -> trigger $ switch (-1)+    _           -> return False++-- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be+-- intercepted by the PagerHints hook, which in turn can instruct XMonad to+-- switch to a different layout.+switch :: (MonadIO m) => Int -> m ()+switch n = liftIO $ withDefaultCtx $ do+  cmd <- getAtom xLayoutProp+  sendCommandEvent cmd (fromIntegral n)

@@ -13,23 +13,20 @@ import qualified Data.Map as M import Data.Text ( Text ) import qualified Data.Text as T-import DBus.Client.Simple ( connectSession )+import DBus 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+  let trackMatcher = matchAny { matchSender = Nothing                                , matchDestination = Nothing                                , matchPath = Just "/Player"                                , matchInterface = Just "org.freedesktop.MediaPlayer"                                , matchMember = Just "TrackChange"                                }-      stateMatcher = MatchRule { matchSender = Nothing+      stateMatcher = matchAny { matchSender = Nothing                                , matchDestination = Nothing                                , matchPath = Just "/Player"                                , matchInterface = Just "org.freedesktop.MediaPlayer"@@ -45,15 +42,16 @@   fromVariant val  -trackCallback :: Label -> BusName -> Signal -> IO ()-trackCallback w _ Signal { signalBody = [variant] } = do+trackCallback :: Label -> Signal -> IO ()+trackCallback w s = do   let v :: Maybe (M.Map Text Variant)       v = fromVariant variant+      [variant] = signalBody s   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)+          msg = escapeMarkup $ printf "%s - %s" (T.unpack artist) (T.unpack track)           txt = "<span fgcolor='yellow'>Now Playing:</span> " ++ msg       postGUIAsync $ do         -- In case the widget was hidden due to a stop/pause, forcibly@@ -61,11 +59,10 @@         labelSetMarkup w txt         widgetShowAll w     _ -> return ()-trackCallback _ _ _ = return () -stateCallback :: Label -> BusName -> Signal -> IO ()-stateCallback w _ Signal { signalBody = [bdy] } =-  case fromVariant bdy of+stateCallback :: Label -> Signal -> IO ()+stateCallback w s =+  case fromVariant (signalBody s !! 0) of     Just st -> case structureItems st of       (pstate:_) -> case (fromVariant pstate) :: Maybe Int32 of         Just 2 -> postGUIAsync $ widgetHideAll w@@ -74,7 +71,6 @@         _ -> return ()       _ -> return ()     _ -> return ()-stateCallback _ _ _ = return ()  mprisNew :: IO Widget mprisNew = do

@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This is a "Now Playing"-style widget that listens for MPRIS+-- events on DBus.  Various media players implement this.  This widget+-- works with version 2 of the MPRIS protocol+-- (http://www.mpris.org/2.0/spec.html).+--+module System.Taffybar.MPRIS2 ( mpris2New ) where++import Data.Maybe ( listToMaybe )+import DBus+import DBus.Client+import Data.List (isPrefixOf)+import Graphics.UI.Gtk hiding ( Signal, Variant )+import Text.Printf++mpris2New :: IO Widget+mpris2New = do+  label <- labelNew Nothing+  widgetShowAll label+  _ <- on label realize $ initLabel label+  return (toWidget label)++unpack :: IsVariant a => Variant -> a+unpack var = case fromVariant var of+  Just x -> x+  Nothing -> error("Could not unpack variant: " ++ show var)++initLabel :: Label -> IO ()+initLabel w = do+  client <- connectSession+  -- Set initial song state/info+  reqSongInfo w client+  listen client propMatcher (callBack w)+  return ()+    where callBack label s = do+            let items = dictionaryItems $ unpack (signalBody s !! 1)+            updatePlaybackStatus label items+            updateMetadata label items+            return ()+          propMatcher = matchAny { matchSender = Nothing+                                 , matchDestination = Nothing+                                 , matchPath = Just "/org/mpris/MediaPlayer2"+                                 , matchInterface = Just "org.freedesktop.DBus.Properties"+                                 , matchMember = Just "PropertiesChanged"+                                 }++reqSongInfo :: Label -> Client -> IO ()+reqSongInfo w client = do+  rep <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames")+                         { methodCallDestination = Just "org.freedesktop.DBus" }+  let plist = unpack $ methodReturnBody rep !! 0+  let players = filter (isPrefixOf "org.mpris.MediaPlayer2.") plist+  case length players of+    0 -> return ()+    _ -> do+      reply <- getProperty client (players !! 0) "Metadata"+      updateSongInfo w $ dictionaryItems $ (unpack . unpack) (methodReturnBody reply !! 0)+      reply' <- getProperty client (players !! 0) "PlaybackStatus"+      let status = (unpack . unpack) (methodReturnBody reply' !! 0) :: String+      case status of+        "Playing" -> postGUIAsync $ widgetShowAll w+        "Paused"  -> postGUIAsync $ widgetHideAll w+        "Stopped" -> postGUIAsync $ widgetHideAll w+        _         -> return ()++getProperty :: Client -> String -> String -> IO MethodReturn+getProperty client name property = do+  call_ client (methodCall "/org/mpris/MediaPlayer2" "org.freedesktop.DBus.Properties" "Get")+    { methodCallDestination = Just (busName_ name)+    , methodCallBody = [ toVariant ("org.mpris.MediaPlayer2.Player" :: String),+                         toVariant property ]+    }++setSongInfo :: Label -> String -> String -> IO ()+setSongInfo w artist title = do+  let msg = escapeMarkup $ printf "%s - %s" (cutoff 15 artist) (cutoff 30 title)+      txt = "<span fgcolor='yellow'>▶</span> " ++ msg+  postGUIAsync $ do+    labelSetMarkup w txt+    widgetShowAll w+  where cutoff n xs | length xs <= n = xs+                    | otherwise      = take n xs ++ "…"++updatePlaybackStatus :: Label -> [(Variant, Variant)] -> IO ()+updatePlaybackStatus w items = do+  case lookup (toVariant ("PlaybackStatus" :: String)) items of+    Just a -> do+      case (unpack . unpack) a :: String of+        "Playing" -> postGUIAsync $ widgetShowAll w+        "Paused"  -> postGUIAsync $ widgetHideAll w+        "Stopped" -> postGUIAsync $ widgetHideAll w+        _         -> return ()+    Nothing -> do+      return ()++updateSongInfo :: Label -> [(Variant, Variant)] -> IO ()+updateSongInfo w items =+  case parseArtistAndTitle of+    Just (artist, title) -> setSongInfo w artist title+    Nothing -> return ()+  where+    parseArtistAndTitle = do+      aLookup <- lookup (toVariant ("xesam:artist" :: String)) items+      tLookup <- lookup (toVariant ("xesam:title" :: String)) items+      let artists = (unpack . unpack) aLookup :: [String]+          title = (unpack . unpack) tLookup :: String+      artist <- listToMaybe artists+      return (artist, title)++updateMetadata :: Label -> [(Variant, Variant)] -> IO ()+updateMetadata w items = do+  case lookup (toVariant ("Metadata" :: String)) items of+    Just meta -> do+      let metaItems = dictionaryItems $ (unpack . unpack) meta+      updateSongInfo w metaItems+    Nothing -> return ()

@@ -1,19 +1,44 @@-module System.Taffybar.NetMonitor where+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.NetMonitor+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple text widget that displays incoming\/outgoing network traffic over+-- one selected interface, as provided by the "System.Information.Network"+-- module.+--+----------------------------------------------------------------------------- +module System.Taffybar.NetMonitor (netMonitorNew) where++import Data.IORef import Graphics.UI.Gtk import System.Information.Network (getNetInfo)-import System.Information.StreamInfo (getTransfer) import System.Taffybar.Widgets.PollingLabel import Text.Printf (printf) -netMonitorNew :: Double -> String -> IO Widget+-- | Creates a new network monitor widget. It consists of two 'PollingLabel's,+-- one for incoming and one for outgoing traffic fed by regular calls to+-- 'getNetInfo'.+netMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 1.5)+              -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")+              -> IO Widget netMonitorNew interval interface = do-    label <- pollingLabelNew "" interval $ showNetInfo interface+    sample <- newIORef [0, 0]+    label  <- pollingLabelNew "" interval $ showInfo sample interval interface     widgetShowAll label     return $ toWidget label-    where-        showNetInfo :: String -> IO String-        showNetInfo interface = do-            trans <- getTransfer 0.3 $ getNetInfo interface-            let [incoming, outgoing] = map (/1e3) trans-            return $ printf "▼ %.2fkb/s ▲ %.2fkb/s" incoming outgoing++showInfo :: IORef [Integer] -> Double -> String -> IO String+showInfo sample interval interface = do+    thisSample <- getNetInfo interface+    lastSample <- readIORef sample+    writeIORef sample thisSample+    let deltas = map fromIntegral $ zipWith (-) thisSample lastSample+        [incoming, outgoing] = map (/(interval*1e3)) deltas+    return $ printf "▼ %.2fkb/s ▲ %.2fkb/s" incoming outgoing

@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Pager+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Common support for pager widgets. This module does not provide itself+-- any widgets, but implements an event dispatcher on which widgets can+-- subscribe the desktop events they're interested in, as well as common+-- configuration facilities.+--+-- N.B. If you're just looking for a drop-in replacement for the+-- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require+-- DBus, you may want to see first "System.Taffybar.TaffyPager".+--+-- You need only one Pager component to instantiate any number of pager+-- widgets:+--+-- > pager <- pagerNew defaultPagerConfig+-- >+-- > let wss = wspaceSwitcherNew pager  -- Workspace Switcher widget+-- >     los = layoutSwitcherNew pager  -- Layout Switcher widget+-- >     wnd = windowSwitcherNew pager  -- Window Switcher widget+--+-----------------------------------------------------------------------------++module System.Taffybar.Pager+  ( Pager (config)+  , PagerConfig (..)+  , defaultPagerConfig+  , pagerNew+  , subscribe+  , colorize+  , shorten+  , wrap+  , escape+  ) where++import Control.Concurrent (forkIO)+import Control.Exception as E+import Control.Monad.Reader+import Data.IORef+import Graphics.UI.Gtk (Markup, escapeMarkup)+import Graphics.X11.Types+import Graphics.X11.Xlib.Extras+import Text.Printf (printf)++import System.Information.X11DesktopInfo++type Listener = Event -> IO ()+type Filter = Atom+type SubscriptionList = IORef [(Listener, Filter)]++-- | Structure contanining functions to customize the pretty printing of+-- different widget elements.+data PagerConfig = PagerConfig+  { activeWindow     :: String -> Markup -- ^ the name of the active window.+  , activeLayout     :: String -> Markup -- ^ the currently active layout.+  , activeWorkspace  :: String -> Markup -- ^ the currently active workspace.+  , hiddenWorkspace  :: String -> Markup -- ^ inactive workspace with windows.+  , emptyWorkspace   :: String -> Markup -- ^ inactive workspace with no windows.+  , visibleWorkspace :: String -> Markup -- ^ all other visible workspaces (Xinerama or XRandR).+  , urgentWorkspace  :: String -> Markup -- ^ workspaces containing windows with the urgency hint set.+  , widgetSep        :: Markup           -- ^ separator to use between desktop widgets in 'TaffyPager'.+  }++-- | Structure containing the state of the Pager.+data Pager = Pager+  { config  :: PagerConfig -- ^ the configuration settings.+  , clients :: SubscriptionList -- ^ functions to apply on incoming events depending on their types.+  }++-- | Default pretty printing options.+defaultPagerConfig :: PagerConfig+defaultPagerConfig   = PagerConfig+  { activeWindow     = colorize "green" "" . escape . shorten 40+  , activeLayout     = escape+  , activeWorkspace  = colorize "yellow" "" . wrap "[" "]" . escape+  , hiddenWorkspace  = escape+  , emptyWorkspace   = escape+  , visibleWorkspace = wrap "(" ")" . escape+  , urgentWorkspace  = colorize "red" "yellow" . escape+  , widgetSep        = " : "+  }++-- | Creates a new Pager component (wrapped in the IO Monad) that can be+-- used by widgets for subscribing X11 events.+pagerNew :: PagerConfig -> IO Pager+pagerNew cfg = do+  ref <- newIORef []+  let pager = Pager cfg ref+  _ <- forkIO $ withDefaultCtx $ eventLoop (handleEvent ref)+  return pager+    where handleEvent :: SubscriptionList -> Event -> IO ()+          handleEvent ref event = do+            listeners <- readIORef ref+            mapM_ (notify event) listeners++-- | Passes the given Event to the given Listener, but only if it was+-- registered for that type of events via 'subscribe'.+notify :: Event -> (Listener, Filter) -> IO ()+notify event (listener, eventFilter) =+  case event of+    PropertyEvent _ _ _ _ _ atom _ _ ->+      when (atom == eventFilter) $ E.catch (listener event) ignoreIOException+    _ -> return ()++-- | Registers the given Listener as a subscriber of events of the given+-- type: whenever a new event of the type with the given name arrives to+-- the Pager, it will execute Listener on it.+subscribe :: Pager -> Listener -> String -> IO ()+subscribe pager listener filterName = do+  eventFilter <- withDefaultCtx $ getAtom filterName+  registered <- readIORef (clients pager)+  let next = (listener, eventFilter)+  writeIORef (clients pager) (next : registered)++ignoreIOException :: IOException -> IO ()+ignoreIOException _ = return ()++-- | Creates markup with the given foreground and background colors and the+-- given contents.+colorize :: String -- ^ Foreground color.+         -> String -- ^ Background color.+         -> String -- ^ Contents.+         -> Markup+colorize fg bg = printf "<span%s%s>%s</span>" (attr "fg" fg) (attr "bg" bg)+  where attr name value+          | null value = ""+          | otherwise  = printf " %scolor=\"%s\"" name value++-- | Limit a string to a certain length, adding "..." if truncated.+shorten :: Int -> String -> String+shorten l s+  | length s <= l = s+  | l >= 3        = take (l - 3) s ++ "..."+  | otherwise     = "..."++-- | Wrap the given string in the given delimiters.+wrap :: String -- ^ Left delimiter.+     -> String -- ^ Right delimiter.+     -> String -- ^ Output string.+     -> String+wrap open close s = open ++ s ++ close++-- | Escape strings so that they can be safely displayed by Pango in the+-- bar widget+escape :: String -> String+escape = escapeMarkup

@@ -1,72 +1,93 @@ -- | 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+module System.Taffybar.SimpleClock (+  textClockNew,+  textClockNewWith,+  defaultClockConfig,+  ClockConfig(..)+  ) where  import Control.Monad.Trans ( MonadIO, liftIO )+import Data.Maybe ( fromMaybe )+import Data.Time.Calendar ( toGregorian )+import qualified Data.Time.Clock as Clock 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+import System.Taffybar.Widgets.Util  makeCalendar :: IO Window makeCalendar = do   container <- windowNew   cal <- calendarNew   containerAdd container cal+  -- update the date on show+  _ <- onShow container $ liftIO $ resetCalendarDate cal+  -- prevent calendar from being destroyed, it can be only hidden:+  _ <- on container deleteEvent $ do+    liftIO (widgetHideAll container)+    return True   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+resetCalendarDate :: Calendar -> IO ()+resetCalendarDate cal = do+  (y,m,d) <- Clock.getCurrentTime >>= return . toGregorian . Clock.utctDay+  calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y)+  calendarSelectDay cal (fromIntegral d) +toggleCalendar :: WidgetClass w => w -> Window -> IO Bool+toggleCalendar w c = do+  isVis <- get c widgetVisible+  if isVis+    then widgetHideAll c+    else do+      attachPopup w "Calendar" c+      displayPopup w 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+textClockNew :: Maybe TimeLocale -> String -> Double -> IO Widget+textClockNew userLocale fmt updateSeconds =+  textClockNewWith cfg fmt updateSeconds+  where+    cfg = defaultClockConfig { clockTimeLocale = 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)+data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone+                               , clockTimeLocale :: Maybe TimeLocale+                               }+                               deriving (Eq, Ord, Show) ---  l <- labelNew Nothing+-- | A clock configuration that defaults to the current locale+defaultClockConfig :: ClockConfig+defaultClockConfig = ClockConfig Nothing Nothing++-- | A configurable text-based clock widget.  It currently allows for+-- a configurable time zone through the 'ClockConfig'.+--+-- See also 'textClockNew'.+textClockNewWith :: ClockConfig -> String -> Double -> IO Widget+textClockNewWith cfg fmt updateSeconds = do+  defaultTimeZone <- getCurrentTimeZone+  let timeLocale = fromMaybe defaultTimeLocale userLocale+      timeZone = fromMaybe defaultTimeZone userZone+  l    <- pollingLabelNew "" updateSeconds (getCurrentTime' timeLocale fmt timeZone)   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)+  _ <- on ebox buttonPressEvent $ onClick [SingleClick] (toggleCalendar l cal)   widgetShowAll ebox--  -- The widget in the bar is actuall the eventbox   return (toWidget ebox)+  where+    userZone = clockTimeZone cfg+    userLocale = clockTimeLocale cfg+    -- alternate getCurrentTime that takes a specific TZ+    getCurrentTime' :: TimeLocale -> String -> TimeZone -> IO String+    getCurrentTime' l f z =+      return . formatTime l f . utcToZonedTime z =<< Clock.getCurrentTime

@@ -17,7 +17,7 @@     widgetShowAll w     boxPackStart box w PackNatural 0 -  _ <- on trayManager trayIconRemoved $ \w -> do+  _ <- on trayManager trayIconRemoved $ \_ -> do     putStrLn "Tray icon removed"    widgetShowAll box

@@ -0,0 +1,94 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.TaffyPager+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides a drop-in replacement for the XMonadLog widget+-- that allows to:+--+-- * click on a workspace label to switch to that workspace,+--+-- * left-click on the layout label to switch to the next layout, and+-- right-click to switch to the first layout,+--+-- * click on the window title to pop-up a list of all the currently open+-- windows that can be clicked to switch to any of them,+--+-- All its interactions with the windows manager are performed via EWMH+-- hints and X11 events.+--+-- This widget is actually only a convenience wrapper around a Pager, a+-- WorkspaceSwitcher, a LayoutSwitcher and a WindowSwitcher. If you are+-- looking for more advanced configurations (like having components+-- displayed separately, or using only part of them), consult directly the+-- documentation for each of the components.+--+-----------------------------------------------------------------------------++module System.Taffybar.TaffyPager (+  -- * Usage+  -- $usage+  taffyPagerNew+, PagerConfig (..)+, defaultPagerConfig+) where++import Graphics.UI.Gtk+import System.Taffybar.Pager+import System.Taffybar.WorkspaceSwitcher+import System.Taffybar.LayoutSwitcher+import System.Taffybar.WindowSwitcher++-- $usage+--+-- This widget requires that two hooks be installed in your @xmonad.hs@+-- configuration: EwmhDesktops from the XMonadContrib project, and the one+-- provided in the "System.Taffybar.Hooks.PagerHints" module:+--+-- > import XMonad.Hooks.EwmhDesktops (ewmh)+-- > import System.Taffybar.Hooks.PagerHints (pagerHints)+-- > main = do+-- >   xmonad $ ewmh $ pagerHints $ defaultConfig+-- > ...+--+-- That's all: no log hooks, no urgency hooks, no DBus client. Once you've+-- configured @xmonad.hs@, you can use the widget in your @taffybar.hs@+-- file:+--+-- > import System.Taffybar.TaffyPager+-- > main = do+-- >   let pager = taffyPagerNew defaultPagerConfig+--+-- now you can use @pager@ as any other Taffybar widget.++-- | Create a new TaffyPager widget.+taffyPagerNew :: PagerConfig -> IO Widget+taffyPagerNew cfg = do+  pgr <- pagerNew cfg+  wss <- wspaceSwitcherNew pgr+  los <- layoutSwitcherNew pgr+  wnd <- windowSwitcherNew pgr+  sp1 <- separator cfg+  sp2 <- separator cfg+  box <- hBoxNew False 0++  boxPackStart box wss PackNatural 0+  boxPackStart box sp1 PackNatural 0+  boxPackStart box los PackNatural 0+  boxPackStart box sp2 PackNatural 0+  boxPackStart box wnd PackNatural 0++  widgetShowAll box+  return (toWidget box)++-- | Create a new separator label to put between two sub-components.+separator :: PagerConfig -> IO Label+separator cfg = do+  sep <- labelNew Nothing+  labelSetMarkup sep (widgetSep cfg)+  return sep

@@ -1,7 +1,7 @@ -- | 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+-- <http://www.nws.noaa.gov/tg/siteloc.php> -- -- For example, Madison, WI is KMSN. --@@ -67,6 +67,7 @@   WeatherFormatter(WeatherFormatter),   -- * Constructor   weatherNew,+  weatherCustomNew,   defaultWeatherConfig   ) where @@ -231,12 +232,15 @@                          , ("pressure", show (pressure wi))                          ] tpl -getCurrentWeather :: String -> StringTemplate String -> WeatherConfig -> IO String-getCurrentWeather url tpl cfg = do-  dat <- getWeather url+getCurrentWeather :: IO (Either String WeatherInfo)+    -> StringTemplate String+    -> WeatherFormatter+    -> IO String+getCurrentWeather getter tpl formatter = do+  dat <- getter   case dat of     Right wi -> do-      case weatherFormatter cfg of+      case formatter of         DefaultWeatherFormatter -> return (defaultFormatter tpl wi)         WeatherFormatter f -> return (f wi)     Left err -> do@@ -277,9 +281,19 @@               -> IO Widget weatherNew cfg delayMinutes = do   let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)-      tpl' = newSTMP (weatherTemplate cfg)+      getter = getWeather url+  weatherCustomNew getter (weatherTemplate cfg) (weatherFormatter cfg) delayMinutes -  l <- pollingLabelNew "N/A" (delayMinutes * 60) (getCurrentWeather url tpl' cfg)+-- | Create a periodically-updating weather widget using custom weather getter+weatherCustomNew :: IO (Either String WeatherInfo) -- ^ Weather querying action+                 -> String                         -- ^ Weather template+                 -> WeatherFormatter               -- ^ Weather formatter+                 -> Double                         -- ^ Polling period in _minutes_+                 -> IO Widget+weatherCustomNew getter tpl formatter delayMinutes = do+  let tpl' = newSTMP tpl++  l <- pollingLabelNew "N/A" (delayMinutes * 60) (getCurrentWeather getter tpl' formatter)    widgetShowAll l   return l

@@ -13,6 +13,7 @@   -- * Types   GraphHandle,   GraphConfig(..),+  GraphDirection(..),   -- * Functions   graphNew,   graphAddSample,@@ -25,6 +26,7 @@ import Data.Foldable ( mapM_ ) import qualified Data.Sequence as S import Graphics.Rendering.Cairo+import Graphics.Rendering.Cairo.Matrix hiding (scale, translate) import Graphics.UI.Gtk  newtype GraphHandle = GH (MVar GraphState)@@ -35,6 +37,8 @@              , graphConfig :: GraphConfig              } +data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq)+ -- | The configuration options for the graph.  The padding is the -- number of pixels reserved as blank space around the widget in each -- direction.@@ -46,6 +50,7 @@               , 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)+              , graphDirection :: GraphDirection               }  defaultGraphConfig :: GraphConfig@@ -56,6 +61,7 @@                                  , graphHistorySize = 20                                  , graphLabel = Nothing                                  , graphWidth = 50+                                 , graphDirection = LEFT_TO_RIGHT                                  }  -- | Add a data point to the graph for each of the tracked data sets.@@ -112,7 +118,6 @@    setLineWidth 0.1 -   let pad = graphPadding cfg    -- Make the new origin be inside the frame and then scale the@@ -122,6 +127,12 @@   let xS = fromIntegral (w - 2 * pad - 2) / fromIntegral w       yS = fromIntegral (h - 2 * pad - 2) / fromIntegral h   scale xS yS++  -- If right-to-left direction is requested, apply an horizontal inversion+  -- transformation with an offset to the right equal to the width of the widget.+  if graphDirection cfg == RIGHT_TO_LEFT+      then transform $ Matrix (-1) 0 0 1 (fromIntegral w) 0+      else return ()    let pctToY pct = fromIntegral h * (1 - pct)       histsAndColors = zip hists (graphDataColors cfg)

@@ -4,6 +4,7 @@   -- * Types   GraphHandle,   GraphConfig(..),+  GraphDirection(..),   -- * Constructors and accessors   pollingGraphNew,   defaultGraphConfig

@@ -2,10 +2,8 @@ -- 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.Exception as E import Control.Monad ( forever ) import Graphics.UI.Gtk @@ -35,7 +33,7 @@       let tryUpdate = do             str <- cmd             postGUIAsync $ labelSetMarkup l str-      catch tryUpdate ignoreIOException+      E.catch tryUpdate ignoreIOException       threadDelay $ floor (interval * 1000000)     return () 

@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widgets.Util+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Utility functions to facilitate building GTK interfaces.+--+-----------------------------------------------------------------------------++module System.Taffybar.Widgets.Util where++import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Graphics.UI.Gtk++-- | Execute the given action as a response to any of the given types+-- of mouse button clicks.+onClick :: [Click] -- ^ Types of button clicks to listen to.+        -> IO a    -- ^ Action to execute.+        -> EventM EButton Bool+onClick triggers action = tryEvent $ do+  click <- eventClick+  when (click `elem` triggers) $ liftIO action >> return ()++-- | Attach the given widget as a popup with the given title to the+-- given window. The newly attached popup is not shown initially. Use+-- the 'displayPopup' function to display it.+attachPopup :: (WidgetClass w) => w -- ^ The widget to set as popup.+            -> String         -- ^ The title of the popup.+            -> Window         -- ^ The window to attach the popup to.+            -> IO ()+attachPopup widget title window = do+  set window [ windowTitle := title+             , windowTypeHint := WindowTypeHintTooltip+             , windowSkipTaskbarHint := True+             ]+  windowSetSkipPagerHint window True+  windowSetKeepAbove window True+  windowStick window+  Just topLevel <- widgetGetAncestor widget gTypeWindow+  let topLevelWindow = castToWindow topLevel+  windowSetTransientFor window topLevelWindow++-- | Display the given popup widget (previously prepared using the+-- 'attachPopup' function) immediately beneath (or above) the given+-- window.+displayPopup :: (WidgetClass w) => w -- ^ The popup widget.+             -> Window -- ^ The window the widget was attached to.+             -> IO ()+displayPopup widget window = do+  windowSetPosition window WinPosMouse+  (x, y ) <- windowGetPosition window+  (_, y') <- widgetGetSize widget+  widgetShowAll window+  if y > y'+    then windowMove window x (y - y')+    else windowMove window x y'

@@ -27,7 +27,7 @@  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+            , barBackgroundColor :: Double -> (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@@ -38,7 +38,7 @@ -- 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)+                               , barBackgroundColor = const (0, 0, 0)                                , barColor = c                                , barPadding = 2                                , barWidth = 15@@ -58,13 +58,13 @@ clamp :: Double -> Double -> Double -> Double clamp lo hi d = max lo $ min hi d -renderFrame :: BarConfig -> Int -> Int -> Render ()-renderFrame cfg width height = do+renderFrame :: Double -> BarConfig -> Int -> Int -> Render ()+renderFrame pct cfg width height = do   let fwidth = fromIntegral width       fheight = fromIntegral height    -- Now draw the user's requested background, respecting padding-  let (bgR, bgG, bgB) = barBackgroundColor cfg+  let (bgR, bgG, bgB) = barBackgroundColor cfg pct       pad = barPadding cfg       fpad = fromIntegral pad   setSourceRGB bgR bgG bgB@@ -78,10 +78,8 @@   rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad)   stroke --- renderBar :: Double -> (Double, Double, Double) -> Int -> Int -> Render () renderBar :: Double -> BarConfig -> Int -> Int -> Render () renderBar pct cfg width height = do--- renderBar pct (r, g, b) width height = do   let direction = barDirection cfg       activeHeight = case direction of                        VERTICAL   -> pct * (fromIntegral height)@@ -94,7 +92,7 @@                        HORIZONTAL -> 0       pad = barPadding cfg -  renderFrame cfg width height+  renderFrame pct cfg width height    -- After we draw the frame, transform the coordinate space so that   -- we only draw within the frame.

@@ -0,0 +1,169 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.WindowSwitcher+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Text widget that shows the title of the currently focused window and+-- that, when clicked with the mouse, displays a pop-up with a list of all+-- currently open windows that allows to switch to any of them.+--+-- N.B. If you're just looking for a drop-in replacement for the+-- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require+-- DBus, you may want to see first "System.Taffybar.TaffyPager".+--+-----------------------------------------------------------------------------++module System.Taffybar.WindowSwitcher (+  -- * Usage+  -- $usage+  windowSwitcherNew+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.IORef+import Graphics.UI.Gtk+import Graphics.UI.Gtk.ModelView as M+import Graphics.X11.Xlib.Extras (Event)+import System.Information.EWMHDesktopInfo+import System.Taffybar.Pager+import System.Taffybar.Widgets.Util++-- $usage+--+-- This widget requires that the EwmhDesktops hook from the XMonadContrib+-- project be installed in your @xmonad.hs@ file:+--+-- > import XMonad.Hooks.EwmhDesktops (ewmh)+-- > main = do+-- >   xmonad $ ewmh $ defaultConfig+-- > ...+--+-- Once you've properly configured @xmonad.hs@, you can use the widget in+-- your @taffybar.hs@ file:+--+-- > import System.Taffybar.WindowSwitcher+-- > main = do+-- >   pager <- pagerNew defaultPagerConfig+-- >   let wnd = windowSwitcherNew pager+--+-- now you can use @wnd@ as any other Taffybar widget.++-- | Create a new WindowSwitcher widget that will use the given Pager as+-- its source of events.+windowSwitcherNew :: Pager -> IO Widget+windowSwitcherNew pager = do+  label <- labelNew Nothing+  let cfg = config pager+      callback = pagerCallback cfg label+  subscribe pager callback "_NET_ACTIVE_WINDOW"+  assembleWidget label++-- | Build a suitable callback function that can be registered as Listener+-- of "_NET_ACTIVE_WINDOW" standard events. It will keep track of the+-- currently focused window.+pagerCallback :: PagerConfig -> Label -> Event -> IO ()+pagerCallback cfg label _ = do+  title <- withDefaultCtx getActiveWindowTitle+  let decorate = activeWindow cfg+  postGUIAsync $ labelSetMarkup label (decorate title)++-- | Build the graphical representation of the widget.+assembleWidget :: Label -> IO Widget+assembleWidget l = do+  box <- eventBoxNew+  containerAdd box l+  eventBoxSetVisibleWindow box False+  ref <- newIORef []+  _ <- on box buttonPressEvent $ onClick [SingleClick] (toggleSelector l ref)+  widgetShowAll box+  return (toWidget box)++-- | Either create a new pop-up window (aka "selector") if none is+-- currently present, or destroy the one being currently displayed.+toggleSelector :: Label -- ^ Parent of the pop-up window to create.+               -> IORef [Window] -- ^ Last created pop-up window (if any)+               -> IO Bool+toggleSelector label ref = do+  win <- readIORef ref+  case win of+    x:_  -> killSelector x ref+    []   -> do+      selector <- createSelector ref+      case selector of+        Just sel -> do+          title <- labelGetText label+          attachPopup label title sel+          displayPopup label sel+        Nothing -> return ()+  return True++formatWindow :: [String] -> ((Int, String, a), b) -> String+formatWindow wsNames ((ws, wtitle, _), _) = wsName ++ ": " ++ wtitle+  where wsName = if 0 <= ws && ws < length wsNames+                 then wsNames !! ws+                 else "WS#" ++ show ws++-- | Build a new pop-up containing the titles of all currently open+-- windows, and assign it as a singleton list to the given IORef.+createSelector :: IORef [Window] -> IO (Maybe Window)+createSelector ref = do+  handles  <- withDefaultCtx getWindowHandles+  if null handles then return Nothing else do+    selector <- windowNew+    wsNames  <- withDefaultCtx getWorkspaceNames+    list     <- listStoreNew $ map (formatWindow wsNames) handles+    view     <- makeTreeView list+    column   <- makeColumn list++    _ <- M.treeViewAppendColumn view column+    sel <- M.treeViewGetSelection view+    _ <- M.onSelectionChanged sel $ do+      handlePick sel list handles+      killSelector selector ref+    set selector [ containerChild := view ]+    _ <- on selector deleteEvent $ killSelector selector ref >> return False+    _ <- on selector focusOutEvent $ killSelector selector ref >> return False++    writeIORef ref [selector]+    return (Just selector)++-- | Destroy given pop-up and clean-up the given IORef.+killSelector :: (MonadIO m) => Window -> IORef[Window] -> m ()+killSelector window ref = liftIO $ do+  writeIORef ref []+  postGUIAsync (widgetDestroy window)++-- | Build a new TreeView from the given ListStore containing window+-- titles.+makeTreeView :: ListStore String -> IO TreeView+makeTreeView list = do+  treeview <- M.treeViewNewWithModel list+  M.treeViewSetHeadersVisible treeview False+  return treeview++-- | Build a new TreeViewColumn from the given ListStore containing window+-- titles.+makeColumn :: ListStore String -> IO TreeViewColumn+makeColumn list = do+  col <- M.treeViewColumnNew+  renderer <- M.cellRendererTextNew+  M.cellLayoutPackStart col renderer False+  M.cellLayoutSetAttributes col renderer list $ \ind -> [M.cellText := ind]+  return col++-- | Switch to the window selected by the user in the pop-up.+handlePick :: M.TreeSelection -- ^ Pop-up selection+           -> ListStore String -- ^ List of all available windows+           -> [((Int, String, String), X11Window)] -- ^ workspace, window title, window class and window ID+           -> IO ()+handlePick selection _ handles = do+  row <- M.treeSelectionGetSelectedRows selection+  let idx = head (head row)+      wh = snd (handles !! idx)+  withDefaultCtx (focusWindow wh)+  return ()

@@ -0,0 +1,214 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.WorkspaceSwitcher+-- Copyright   : (c) José A. Romero L.+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Composite widget that displays all currently configured workspaces and+-- allows to switch to any of them by clicking on its label. Supports also+-- urgency hints and (with an additional hook) display of other visible+-- workspaces besides the active one (in Xinerama or XRandR installations).+--+-- N.B. If you're just looking for a drop-in replacement for the+-- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require+-- DBus, you may want to see first "System.Taffybar.TaffyPager".+--+-----------------------------------------------------------------------------++module System.Taffybar.WorkspaceSwitcher (+  -- * Usage+  -- $usage+  wspaceSwitcherNew+) where++import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.IORef+import Data.List ((\\), findIndices)+import Graphics.UI.Gtk hiding (get)+import Graphics.X11.Xlib.Extras++import System.Taffybar.Pager+import System.Information.EWMHDesktopInfo++type Desktop = [Workspace]+data Workspace = Workspace { label  :: Label+                           , name   :: String+                           , urgent :: Bool+                           }+-- $usage+--+-- This widget requires that the EwmhDesktops hook from the XMonadContrib+-- project be installed in your @xmonad.hs@ file:+--+-- > import XMonad.Hooks.EwmhDesktops (ewmh)+-- > main = do+-- >   xmonad $ ewmh $ defaultConfig+-- > ...+--+-- Urgency hooks are not required for the urgency hints displaying to work+-- (since it is also based on desktop events), but if you use @focusUrgent@+-- you may want to keep the \"@withUrgencyHook NoUrgencyHook@\" anyway.+--+-- Unfortunately, in multiple monitor installations EWMH does not provide a+-- way to determine what desktops are shown in secondary displays. Thus, if+-- you have more than one monitor you may want to additionally install the+-- "System.Taffybar.Hooks.PagerHints" hook in your @xmonad.hs@:+--+-- > import System.Taffybar.Hooks.PagerHints (pagerHints)+-- > main = do+-- >   xmonad $ ewmh $ pagerHints $ defaultConfig+-- > ...+--+-- Once you've properly configured @xmonad.hs@, you can use the widget in+-- your @taffybar.hs@ file:+--+-- > import System.Taffybar.WorkspaceSwitcher+-- > main = do+-- >   pager <- pagerNew defaultPagerConfig+-- >   let wss = wspaceSwitcherNew pager+--+-- now you can use @wss@ as any other Taffybar widget.++-- | Create a new WorkspaceSwitcher widget that will use the given Pager as+-- its source of events.+wspaceSwitcherNew :: Pager -> IO Widget+wspaceSwitcherNew pager = do+  desktop <- getDesktop pager+  widget  <- assembleWidget desktop+  deskRef <- newIORef desktop+  let cfg = config pager+      activecb = activeCallback cfg deskRef+      urgentcb = urgentCallback cfg deskRef+  subscribe pager activecb "_NET_CURRENT_DESKTOP"+  subscribe pager urgentcb "WM_HINTS"+  return widget++-- | List of indices of all available workspaces.+allWorkspaces :: Desktop -> [Int]+allWorkspaces desktop = [0 .. length desktop - 1]++-- | Return a list of two-element tuples, one for every workspace,+-- containing the Label widget used to display the name of that specific+-- workspace and a String with its default (unmarked) representation.+getDesktop :: Pager -> IO Desktop+getDesktop pager = do+  names  <- withDefaultCtx getWorkspaceNames+  labels <- toLabels $ map (hiddenWorkspace $ config pager) names+  return $ zipWith (\n l -> Workspace l n False) names labels++-- | Build the graphical representation of the widget.+assembleWidget :: Desktop -> IO Widget+assembleWidget desktop = do+  hbox <- hBoxNew False 0+  mapM_ (addButton hbox desktop) (allWorkspaces desktop)+  widgetShowAll hbox+  return $ toWidget hbox++-- | Build a suitable callback function that can be registered as Listener+-- of "_NET_CURRENT_DESKTOP" standard events. It will track the position of+-- the active workspace in the desktop.+activeCallback :: PagerConfig -> IORef Desktop -> Event -> IO ()+activeCallback cfg deskRef _ = do+  curr <- withDefaultCtx getVisibleWorkspaces+  desktop <- readIORef deskRef+  let visible = head curr+  when (urgent $ desktop !! visible) $+    liftIO $ toggleUrgent deskRef visible False+  transition cfg desktop curr++-- | Build a suitable callback function that can be registered as Listener+-- of "WM_HINTS" standard events. It will display in a different color any+-- workspace (other than the active one) containing one or more windows+-- with its urgency hint set.+urgentCallback :: PagerConfig -> IORef Desktop -> Event -> IO ()+urgentCallback cfg deskRef event = do+  desktop <- readIORef deskRef+  withDefaultCtx $ do+    let window = ev_window event+    isUrgent <- isWindowUrgent window+    when isUrgent $ do+      this <- getCurrentWorkspace+      that <- getWorkspace window+      when (this /= that) $ liftIO $ do+        toggleUrgent deskRef that True+        mark desktop (urgentWorkspace cfg) that++-- | Convert the given list of Strings to a list of Label widgets.+toLabels :: [String] -> IO [Label]+toLabels = mapM labelNewMarkup+  where labelNewMarkup markup = do+          label <- labelNew Nothing+          labelSetMarkup label markup+          return label++-- | Build a new clickable event box containing the Label widget that+-- corresponds to the given index, and add it to the given container.+addButton :: HBox    -- ^ Graphical container.+          -> Desktop -- ^ List of all workspace Labels available.+          -> Int     -- ^ Index of the workspace to use.+          -> IO ()+addButton hbox desktop idx = do+  let lbl = label (desktop !! idx)+  ebox <- eventBoxNew+  eventBoxSetVisibleWindow ebox False+  _ <- on ebox buttonPressEvent $ switch idx+  containerAdd ebox lbl+  boxPackStart hbox ebox PackNatural 0++-- | List of indices of all the workspaces that contain at least one window.+nonEmptyWorkspaces :: IO [Int]+nonEmptyWorkspaces = withDefaultCtx $ mapM getWorkspace =<< getWindows++-- | Re-mark all workspace labels.+transition :: PagerConfig -- ^ Configuration settings.+           -> Desktop     -- ^ All available Labels with their default values.+           -> [Int]       -- ^ Currently visible workspaces (first is active).+           -> IO ()+transition cfg desktop wss = do+  nonEmpty <- fmap (filter (>=0)) nonEmptyWorkspaces+  let urgentWs = findIndices urgent desktop+      allWs    = (allWorkspaces desktop) \\ urgentWs+      nonEmptyWs = nonEmpty \\ urgentWs+  mapM_ (mark desktop $ hiddenWorkspace cfg) nonEmptyWs+  mapM_ (mark desktop $ emptyWorkspace cfg) (allWs \\ nonEmpty)+  mark desktop (activeWorkspace cfg) (head wss)+  mapM_ (mark desktop $ visibleWorkspace cfg) (tail wss)+  mapM_ (mark desktop $ urgentWorkspace cfg) urgentWs++-- | Apply the given marking function to the Label of the workspace with+-- the given index.+mark :: Desktop            -- ^ List of all available labels.+     -> (String -> Markup) -- ^ Marking function.+     -> Int                -- ^ Index of the Label to modify.+     -> IO ()+mark desktop decorate idx = do+  let ws = desktop !! idx+  postGUIAsync $ labelSetMarkup (label ws) $ decorate' (name ws)+  where decorate' = pad . decorate+        pad m | m == [] = m+              | otherwise = ' ' : m++-- | Switch to the workspace with the given index.+switch :: (MonadIO m) => Int -> m Bool+switch idx = do+  liftIO $ withDefaultCtx (switchToWorkspace idx)+  return True++-- | Modify the Desktop inside the given IORef, so that the Workspace at the+-- given index has its "urgent" flag set to the given value.+toggleUrgent :: IORef Desktop -- ^ IORef to modify.+             -> Int           -- ^ Index of the Workspace to replace.+             -> Bool          -- ^ New value of the "urgent" flag.+             -> IO ()+toggleUrgent deskRef idx isUrgent = do+  desktop <- readIORef deskRef+  let ws = desktop !! idx+  unless (isUrgent == urgent ws) $ do+    let ws' = (desktop !! idx) { urgent = isUrgent }+    let (ys, zs) = splitAt idx desktop+        in writeIORef deskRef $ ys ++ (ws' : tail zs)

@@ -24,17 +24,13 @@   ) where  import Codec.Binary.UTF8.String ( decodeString )-import DBus.Client.Simple ( connectSession, emit, Client )-import DBus.Client ( listen, MatchRule(..) )-import DBus.Types-import DBus.Message+import DBus ( toVariant, fromVariant, Signal(..), signal )+import DBus.Client ( listen, matchAny, MatchRule(..), connectSession, emit, Client ) import Graphics.UI.Gtk hiding ( Signal )  import XMonad import XMonad.Hooks.DynamicLog -import Web.Encodings ( decodeHtml, encodeHtml )- -- | This is a DBus-based logger that can be used from XMonad to log -- to this widget.  This version lets you specify the format for the -- log using a pretty printer (e.g., 'taffybarPP').@@ -47,12 +43,13 @@  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 , "\">"]+  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+taffybarEscape = escapeMarkup  -- | The same as defaultPP in XMonad.Hooks.DynamicLog taffybarDefaultPP :: PP@@ -81,11 +78,11 @@   -- We need to decode the string back into a real String before we   -- send it over dbus.   let str' = decodeString str-  emit client "/org/xmonad/Log" "org.xmonad.Log" "Update" [ toVariant str' ]+  emit client (signal "/org/xmonad/Log" "org.xmonad.Log" "Update") { signalBody = [ toVariant str' ] }  setupDbus :: Label -> IO () setupDbus w = do-  let matcher = MatchRule { matchSender = Nothing+  let matcher = matchAny { matchSender = Nothing                           , matchDestination = Nothing                           , matchPath = Just "/org/xmonad/Log"                           , matchInterface = Just "org.xmonad.Log"@@ -96,8 +93,8 @@    listen client matcher (callback w) -callback :: Label -> BusName -> Signal -> IO ()-callback w _ sig = do+callback :: Label -> Signal -> IO ()+callback w sig = do   let [bdy] = signalBody sig       Just status = fromVariant bdy   postGUIAsync $ labelSetMarkup w status

@@ -1,5 +1,5 @@ name: taffybar-version: 0.2.1+version: 0.3.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -18,6 +18,22 @@   gtk2hs and provides several widgets (including a few graphical ones).   It also sports an optional snazzy system tray.   .+  Changes in v0.3.0:+  .+    * A new pager (System.Taffybar.TaffyPager) from José A. Romero L.  This pager is a drop-in replacement for the dbus-based XMonadLog widget.  It communicates via X atoms and EWMH like a real pager.  It even supports changing workspaces by clicking on them.  I recommend this over the old widget.+  .+    * Added an MPRIS2 widget (contributed by Igor Babuschkin)+  .+    * Ported to use the newer merged dbus library instead of dbus-client/dbus-core (contributed by CJ van den Berg)+  .+    * Finally have the calendar widget pop up over the date/time widget (contributed by José A. Romero)+  .+    * GHC 7.6 compatibility+  .+    * Vertical bars can now have dynamic background colors (suggested by Elliot Wolk)+  .+    * Bug fixes+  .   Changes in v0.2.1:   .     * More robust strut handling for multiple monitors of different sizes (contributed by Morgan Gibson)@@ -58,10 +74,11 @@ library   default-language: Haskell2010   build-depends: base > 3 && < 5, time, old-locale, containers, text, HTTP,-                 parsec >= 3.1, mtl >= 2, network, web-encodings, cairo,-                 dbus-core >= 0.9.1 && < 1.0, gtk >= 0.12.1, dyre >= 0.8.6,+                 parsec >= 3.1, mtl >= 2, network, cairo,+                 dbus >= 0.10.1 && < 1.0, gtk >= 0.12.1, dyre >= 0.8.6,                  HStringTemplate, gtk-traymanager >= 0.1.2 && < 0.2, xmonad-contrib, xmonad,-                 xdg-basedir, filepath, utf8-string, process+                 xdg-basedir, filepath, utf8-string, process, stm, transformers >= 0.3.0.0,+                 X11 >= 1.5.0.1, split >= 0.1.4.2   hs-source-dirs: src   pkgconfig-depends: gtk+-2.0   exposed-modules: System.Taffybar,@@ -71,20 +88,33 @@                    System.Taffybar.FreedesktopNotifications,                    System.Taffybar.Weather,                    System.Taffybar.MPRIS,+                   System.Taffybar.MPRIS2,                    System.Taffybar.Battery,-                   System.Taffybar.FSMonitor-                   System.Taffybar.NetMonitor+                   System.Taffybar.CPUMonitor,+                   System.Taffybar.DiskIOMonitor,+                   System.Taffybar.FSMonitor,+                   System.Taffybar.LayoutSwitcher,+                   System.Taffybar.NetMonitor,+                   System.Taffybar.Pager,+                   System.Taffybar.TaffyPager,+                   System.Taffybar.WindowSwitcher,+                   System.Taffybar.WorkspaceSwitcher,+                   System.Taffybar.Hooks.PagerHints,                    System.Taffybar.Widgets.Graph,                    System.Taffybar.Widgets.PollingBar,                    System.Taffybar.Widgets.PollingGraph,                    System.Taffybar.Widgets.PollingLabel,+                   System.Taffybar.Widgets.Util,                    System.Taffybar.Widgets.VerticalBar,                    System.Information.StreamInfo,                    System.Information.Battery,+                   System.Information.EWMHDesktopInfo,+                   System.Information.X11DesktopInfo,                    System.Information.Memory,                    System.Information.Network,                    System.Information.CPU,-                   System.Information.CPU2+                   System.Information.CPU2,+                   System.Information.DiskIO   other-modules: System.Taffybar.StrutProperties,                  Paths_taffybar