diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/src/System/Information/Battery.hs b/src/System/Information/Battery.hs --- a/src/System/Information/Battery.hs +++ b/src/System/Information/Battery.hs @@ -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 diff --git a/src/System/Information/CPU2.hs b/src/System/Information/CPU2.hs --- a/src/System/Information/CPU2.hs +++ b/src/System/Information/CPU2.hs @@ -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. +-- 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 diff --git a/src/System/Information/DiskIO.hs b/src/System/Information/DiskIO.hs new file mode 100644 --- /dev/null +++ b/src/System/Information/DiskIO.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Information.DiskIO +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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]) diff --git a/src/System/Information/EWMHDesktopInfo.hs b/src/System/Information/EWMHDesktopInfo.hs new file mode 100644 --- /dev/null +++ b/src/System/Information/EWMHDesktopInfo.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Information.EWMHDesktopInfo +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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) diff --git a/src/System/Information/Network.hs b/src/System/Information/Network.hs --- a/src/System/Information/Network.hs +++ b/src/System/Information/Network.hs @@ -1,7 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Information.Network +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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 diff --git a/src/System/Information/StreamInfo.hs b/src/System/Information/StreamInfo.hs --- a/src/System/Information/StreamInfo.hs +++ b/src/System/Information/StreamInfo.hs @@ -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. +-- 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 diff --git a/src/System/Information/X11DesktopInfo.hs b/src/System/Information/X11DesktopInfo.hs new file mode 100644 --- /dev/null +++ b/src/System/Information/X11DesktopInfo.hs @@ -0,0 +1,205 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Information.X11DesktopInfo +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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 diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -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 diff --git a/src/System/Taffybar/Battery.hs b/src/System/Taffybar/Battery.hs --- a/src/System/Taffybar/Battery.hs +++ b/src/System/Taffybar/Battery.hs @@ -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 diff --git a/src/System/Taffybar/CPUMonitor.hs b/src/System/Taffybar/CPUMonitor.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/CPUMonitor.hs @@ -0,0 +1,38 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.CPUMonitor +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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 diff --git a/src/System/Taffybar/DiskIOMonitor.hs b/src/System/Taffybar/DiskIOMonitor.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/DiskIOMonitor.hs @@ -0,0 +1,37 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.DiskIOMonitor +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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 diff --git a/src/System/Taffybar/FSMonitor.hs b/src/System/Taffybar/FSMonitor.hs --- a/src/System/Taffybar/FSMonitor.hs +++ b/src/System/Taffybar/FSMonitor.hs @@ -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. +-- 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 diff --git a/src/System/Taffybar/FreedesktopNotifications.hs b/src/System/Taffybar/FreedesktopNotifications.hs --- a/src/System/Taffybar/FreedesktopNotifications.hs +++ b/src/System/Taffybar/FreedesktopNotifications.hs @@ -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 diff --git a/src/System/Taffybar/Hooks/PagerHints.hs b/src/System/Taffybar/Hooks/PagerHints.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Hooks/PagerHints.hs @@ -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. +-- 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 diff --git a/src/System/Taffybar/LayoutSwitcher.hs b/src/System/Taffybar/LayoutSwitcher.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/LayoutSwitcher.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.LayoutSwitcher +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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) diff --git a/src/System/Taffybar/MPRIS.hs b/src/System/Taffybar/MPRIS.hs --- a/src/System/Taffybar/MPRIS.hs +++ b/src/System/Taffybar/MPRIS.hs @@ -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 = "Now Playing: " ++ 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 diff --git a/src/System/Taffybar/MPRIS2.hs b/src/System/Taffybar/MPRIS2.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/MPRIS2.hs @@ -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 = "▶ " ++ 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 () diff --git a/src/System/Taffybar/NetMonitor.hs b/src/System/Taffybar/NetMonitor.hs --- a/src/System/Taffybar/NetMonitor.hs +++ b/src/System/Taffybar/NetMonitor.hs @@ -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. +-- 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 diff --git a/src/System/Taffybar/Pager.hs b/src/System/Taffybar/Pager.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Pager.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.Pager +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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 "%s" (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 diff --git a/src/System/Taffybar/SimpleClock.hs b/src/System/Taffybar/SimpleClock.hs --- a/src/System/Taffybar/SimpleClock.hs +++ b/src/System/Taffybar/SimpleClock.hs @@ -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 diff --git a/src/System/Taffybar/Systray.hs b/src/System/Taffybar/Systray.hs --- a/src/System/Taffybar/Systray.hs +++ b/src/System/Taffybar/Systray.hs @@ -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 diff --git a/src/System/Taffybar/TaffyPager.hs b/src/System/Taffybar/TaffyPager.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/TaffyPager.hs @@ -0,0 +1,94 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.TaffyPager +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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 diff --git a/src/System/Taffybar/Weather.hs b/src/System/Taffybar/Weather.hs --- a/src/System/Taffybar/Weather.hs +++ b/src/System/Taffybar/Weather.hs @@ -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 +-- -- -- 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 diff --git a/src/System/Taffybar/Widgets/Graph.hs b/src/System/Taffybar/Widgets/Graph.hs --- a/src/System/Taffybar/Widgets/Graph.hs +++ b/src/System/Taffybar/Widgets/Graph.hs @@ -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) diff --git a/src/System/Taffybar/Widgets/PollingGraph.hs b/src/System/Taffybar/Widgets/PollingGraph.hs --- a/src/System/Taffybar/Widgets/PollingGraph.hs +++ b/src/System/Taffybar/Widgets/PollingGraph.hs @@ -4,6 +4,7 @@ -- * Types GraphHandle, GraphConfig(..), + GraphDirection(..), -- * Constructors and accessors pollingGraphNew, defaultGraphConfig diff --git a/src/System/Taffybar/Widgets/PollingLabel.hs b/src/System/Taffybar/Widgets/PollingLabel.hs --- a/src/System/Taffybar/Widgets/PollingLabel.hs +++ b/src/System/Taffybar/Widgets/PollingLabel.hs @@ -2,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 () diff --git a/src/System/Taffybar/Widgets/Util.hs b/src/System/Taffybar/Widgets/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Widgets/Util.hs @@ -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. +-- 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' diff --git a/src/System/Taffybar/Widgets/VerticalBar.hs b/src/System/Taffybar/Widgets/VerticalBar.hs --- a/src/System/Taffybar/Widgets/VerticalBar.hs +++ b/src/System/Taffybar/Widgets/VerticalBar.hs @@ -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. diff --git a/src/System/Taffybar/WindowSwitcher.hs b/src/System/Taffybar/WindowSwitcher.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/WindowSwitcher.hs @@ -0,0 +1,169 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.WindowSwitcher +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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 () diff --git a/src/System/Taffybar/WorkspaceSwitcher.hs b/src/System/Taffybar/WorkspaceSwitcher.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/WorkspaceSwitcher.hs @@ -0,0 +1,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.WorkspaceSwitcher +-- Copyright : (c) José A. Romero L. +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : José A. Romero L. +-- 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) diff --git a/src/System/Taffybar/XMonadLog.hs b/src/System/Taffybar/XMonadLog.hs --- a/src/System/Taffybar/XMonadLog.hs +++ b/src/System/Taffybar/XMonadLog.hs @@ -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 "" . taffybarEscape - where t = concat [""] + where + t = concat [""] -- | 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 diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -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