diff --git a/src/System/Information/CPU2.hs b/src/System/Information/CPU2.hs new file mode 100644 --- /dev/null +++ b/src/System/Information/CPU2.hs @@ -0,0 +1,17 @@ +module System.Information.CPU2 (getCPULoad) where + +import System.Information.StreamInfo (getLoad, getParsedInfo) + +getCPULoad :: String -> IO [Double] +getCPULoad cpu = do + load <- getLoad 0.05 $ getCPUInfo cpu + return [load!!0 + load!!1, load!!2] + +getCPUInfo :: String -> IO [Integer] +getCPUInfo = getParsedInfo "/proc/stat" parse + +parse :: String -> [(String, [Integer])] +parse = map (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines + +tuplize :: [String] -> (String, [Integer]) +tuplize s = (head s, map read $ tail s) diff --git a/src/System/Information/Network.hs b/src/System/Information/Network.hs new file mode 100644 --- /dev/null +++ b/src/System/Information/Network.hs @@ -0,0 +1,13 @@ +module System.Information.Network (getNetInfo) where + +import System.Information.StreamInfo (getParsedInfo) + +getNetInfo :: String -> IO [Integer] +getNetInfo = getParsedInfo "/proc/net/dev" parse + +parse :: String -> [(String, [Integer])] +parse = map tuplize . map words . drop 2 . lines + +tuplize :: [String] -> (String, [Integer]) +tuplize s = (init $ head s, map read [s!!1, s!!out]) + where out = (length s) - 7 diff --git a/src/System/Information/StreamInfo.hs b/src/System/Information/StreamInfo.hs new file mode 100644 --- /dev/null +++ b/src/System/Information/StreamInfo.hs @@ -0,0 +1,52 @@ +-- | 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 + +import Control.Concurrent (threadDelay) +import Data.Maybe (fromJust) + +-- | 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 +-- desired value. +getParsedInfo :: FilePath -> (String -> [(String, [Integer])]) -> String -> IO [Integer] +getParsedInfo path parser selector = do + file <- readFile path + (length file) `seq` return () + return (fromJust $ lookup selector $ parser file) + +truncVal :: Double -> Double +truncVal v + | isNaN v || v < 0.0 = 0.0 + | otherwise = v + +-- | 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] +probe action delay = do + a <- action + threadDelay $ round (delay * 1e6) + b <- action + 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] +getTransfer interval action = do + deltas <- probe action interval + return $ map (truncVal . (/interval) . fromIntegral) deltas + +-- | Probe the given action and return the relative variation of each of the +-- obtained values against the whole, where the whole is calculated as the sum +-- of all the values in the probe. +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 + diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -136,14 +136,23 @@ data Position = Top | Bottom deriving (Show, Eq) + strutProperties :: Position -- ^ Bar position -> Int -- ^ Bar height - -> Rectangle -- ^ Monitor rectangle + -> Rectangle -- ^ Current monitor rectangle + -> [Rectangle] -- ^ All monitors -> StrutProperties -strutProperties pos bh (Rectangle x _ w _) = case pos of - Top -> (0, 0, bh, 0, 0, 0, 0, 0, x, x2, 0, 0) - Bottom -> (0, 0, 0, bh, 0, 0, 0, 0, 0, 0, x, x2) - where x2 = x + w - 10 +strutProperties pos bh (Rectangle mX mY mW mH) monitors = + propertize pos sX sW sH + where sX = mX + sW = mW - 1 + sH = case pos of Top -> bh + mY + Bottom -> bh + totalH - mY - mH + totalH = maximum $ map bottomY monitors + bottomY (Rectangle _ y _ h) = y + h + propertize p x w h = case p of + Top -> (0, 0, h, 0, 0, 0, 0, 0, x, x+w, 0, 0) + Bottom -> (0, 0, 0, h, 0, 0, 0, 0, 0, 0, x, x+w) data TaffybarConfig = TaffybarConfig { screenNumber :: Int -- ^ The screen number to run the bar on (default is almost always fine) @@ -213,9 +222,10 @@ False -> error $ printf "Screen %d is not available in the default display" (screenNumber cfg) True -> displayGetScreen disp (screenNumber cfg) nmonitors <- screenGetNMonitors screen + allMonitorSizes <- mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)] monitorSize <- case monitorNumber cfg < nmonitors of False -> error $ printf "Monitor %d is not available in the selected screen" (monitorNumber cfg) - True -> screenGetMonitorGeometry screen (monitorNumber cfg) + True -> return $ allMonitorSizes !! monitorNumber cfg window <- windowNew widgetSetName window "Taffybar" @@ -230,6 +240,7 @@ $ strutProperties (barPosition cfg) (barHeight cfg) monitorSize + allMonitorSizes box <- hBoxNew False 10 containerAdd window box diff --git a/src/System/Taffybar/FSMonitor.hs b/src/System/Taffybar/FSMonitor.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/FSMonitor.hs @@ -0,0 +1,18 @@ +module System.Taffybar.FSMonitor where + +import Graphics.UI.Gtk +import System.Process (readProcess) +import System.Taffybar.Widgets.PollingLabel +import Text.Printf (printf) + +fsMonitorNew :: Double -> [String] -> 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 diff --git a/src/System/Taffybar/NetMonitor.hs b/src/System/Taffybar/NetMonitor.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/NetMonitor.hs @@ -0,0 +1,19 @@ +module System.Taffybar.NetMonitor where + +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 +netMonitorNew interval interface = do + label <- pollingLabelNew "" interval $ showNetInfo 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 diff --git a/src/System/Taffybar/Widgets/PollingBar.hs b/src/System/Taffybar/Widgets/PollingBar.hs --- a/src/System/Taffybar/Widgets/PollingBar.hs +++ b/src/System/Taffybar/Widgets/PollingBar.hs @@ -4,6 +4,7 @@ -- * Types VerticalBarHandle, BarConfig(..), + BarDirection(..), -- * Constructors and accessors pollingBarNew, defaultBarConfig 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 @@ -4,6 +4,7 @@ -- * Types VerticalBarHandle, BarConfig(..), + BarDirection(..), -- * Accessors/Constructors verticalBarNew, verticalBarSetPercent, @@ -22,12 +23,15 @@ , barConfig :: BarConfig } +data BarDirection = HORIZONTAL | VERTICAL + data BarConfig = BarConfig { barBorderColor :: (Double, Double, Double) -- ^ Color of the border drawn around the widget , barBackgroundColor :: (Double, Double, Double) -- ^ The background color of the widget , barColor :: Double -> (Double, Double, Double) -- ^ A function to determine the color of the widget for the current data point , barPadding :: Int -- ^ Number of pixels of padding around the widget , barWidth :: Int + , barDirection :: BarDirection } -- | A default bar configuration. The color of the active portion of @@ -38,6 +42,7 @@ , barColor = c , barPadding = 2 , barWidth = 15 + , barDirection = VERTICAL } verticalBarSetPercent :: VerticalBarHandle -> Double -> IO () @@ -77,9 +82,16 @@ renderBar :: Double -> BarConfig -> Int -> Int -> Render () renderBar pct cfg width height = do -- renderBar pct (r, g, b) width height = do - let activeHeight = pct * (fromIntegral height) - activeWidth = fromIntegral width - newOrigin = fromIntegral height - activeHeight + let direction = barDirection cfg + activeHeight = case direction of + VERTICAL -> pct * (fromIntegral height) + HORIZONTAL -> fromIntegral height + activeWidth = case direction of + VERTICAL -> fromIntegral width + HORIZONTAL -> pct * (fromIntegral width) + newOrigin = case direction of + VERTICAL -> fromIntegral height - activeHeight + HORIZONTAL -> 0 pad = barPadding cfg renderFrame cfg width height diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -1,5 +1,5 @@ name: taffybar -version: 0.2.0 +version: 0.2.1 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE @@ -18,6 +18,14 @@ gtk2hs and provides several widgets (including a few graphical ones). It also sports an optional snazzy system tray. . + Changes in v0.2.1: + . + * More robust strut handling for multiple monitors of different sizes (contributed by Morgan Gibson) + . + * New widgets from José A. Romero (network monitor, fs monitor, another CPU monitor) + . + * Allow the bar widget to grow vertically (also contributed by José A. Romero) + . Changes in v0.2.0: . * Add some more flexible formatting options for the XMonadLog widget (contributed by @@ -53,7 +61,7 @@ parsec >= 3.1, mtl >= 2, network, web-encodings, cairo, dbus-core >= 0.9.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 + xdg-basedir, filepath, utf8-string, process hs-source-dirs: src pkgconfig-depends: gtk+-2.0 exposed-modules: System.Taffybar, @@ -64,14 +72,19 @@ System.Taffybar.Weather, System.Taffybar.MPRIS, System.Taffybar.Battery, + System.Taffybar.FSMonitor + System.Taffybar.NetMonitor System.Taffybar.Widgets.Graph, System.Taffybar.Widgets.PollingBar, System.Taffybar.Widgets.PollingGraph, System.Taffybar.Widgets.PollingLabel, System.Taffybar.Widgets.VerticalBar, + System.Information.StreamInfo, System.Information.Battery, System.Information.Memory, - System.Information.CPU + System.Information.Network, + System.Information.CPU, + System.Information.CPU2 other-modules: System.Taffybar.StrutProperties, Paths_taffybar