From e3853a9cb2a9a2cffa174d1334e2ca8ba610f151 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Tue, 21 Dec 2010 02:36:35 +0100 Subject: Haskell sources moved to src/ to unclutter toplevel --- .gitignore | 3 + Commands.hs | 84 ------- Config.hs | 116 ---------- IWlib.hsc | 75 ------- Main.hs | 164 -------------- Parsers.hs | 183 --------------- Plugins.hs | 25 --- Plugins/CommandReader.hs | 39 ---- Plugins/Date.hs | 37 --- Plugins/EWMH.hs | 264 ---------------------- Plugins/HelloWorld.hs | 24 -- Plugins/MBox.hs | 111 --------- Plugins/Mail.hs | 70 ------ Plugins/Monitors.hs | 119 ---------- Plugins/Monitors/Batt.hs | 165 -------------- Plugins/Monitors/Common.hs | 446 ------------------------------------- Plugins/Monitors/CoreCommon.hs | 59 ----- Plugins/Monitors/CoreTemp.hs | 41 ---- Plugins/Monitors/Cpu.hs | 53 ----- Plugins/Monitors/CpuFreq.hs | 43 ---- Plugins/Monitors/Disk.hs | 137 ------------ Plugins/Monitors/MPD.hs | 115 ---------- Plugins/Monitors/Mem.hs | 59 ----- Plugins/Monitors/MultiCpu.hs | 81 ------- Plugins/Monitors/Net.hs | 96 -------- Plugins/Monitors/Swap.hs | 55 ----- Plugins/Monitors/Thermal.hs | 42 ---- Plugins/Monitors/Top.hs | 179 --------------- Plugins/Monitors/Uptime.hs | 50 ----- Plugins/Monitors/Weather.hs | 141 ------------ Plugins/Monitors/Wireless.hs | 34 --- Plugins/PipeReader.hs | 28 --- Plugins/StdinReader.hs | 33 --- Plugins/Utils.hs | 39 ---- Plugins/XMonadLog.hs | 72 ------ Plugins/helloworld.config | 12 - Runnable.hs | 59 ----- Runnable.hs-boot | 8 - StatFS.hsc | 79 ------- XUtil.hsc | 259 --------------------- Xmobar.hs | 306 ------------------------- src/Commands.hs | 84 +++++++ src/Config.hs | 116 ++++++++++ src/IWlib.hsc | 75 +++++++ src/Main.hs | 164 ++++++++++++++ src/Parsers.hs | 183 +++++++++++++++ src/Plugins.hs | 25 +++ src/Plugins/CommandReader.hs | 39 ++++ src/Plugins/Date.hs | 37 +++ src/Plugins/EWMH.hs | 264 ++++++++++++++++++++++ src/Plugins/HelloWorld.hs | 24 ++ src/Plugins/MBox.hs | 111 +++++++++ src/Plugins/Mail.hs | 70 ++++++ src/Plugins/Monitors.hs | 119 ++++++++++ src/Plugins/Monitors/Batt.hs | 165 ++++++++++++++ src/Plugins/Monitors/Common.hs | 446 +++++++++++++++++++++++++++++++++++++ src/Plugins/Monitors/CoreCommon.hs | 59 +++++ src/Plugins/Monitors/CoreTemp.hs | 41 ++++ src/Plugins/Monitors/Cpu.hs | 53 +++++ src/Plugins/Monitors/CpuFreq.hs | 43 ++++ src/Plugins/Monitors/Disk.hs | 137 ++++++++++++ src/Plugins/Monitors/MPD.hs | 115 ++++++++++ src/Plugins/Monitors/Mem.hs | 59 +++++ src/Plugins/Monitors/MultiCpu.hs | 81 +++++++ src/Plugins/Monitors/Net.hs | 96 ++++++++ src/Plugins/Monitors/Swap.hs | 55 +++++ src/Plugins/Monitors/Thermal.hs | 42 ++++ src/Plugins/Monitors/Top.hs | 179 +++++++++++++++ src/Plugins/Monitors/Uptime.hs | 50 +++++ src/Plugins/Monitors/Weather.hs | 141 ++++++++++++ src/Plugins/Monitors/Wireless.hs | 34 +++ src/Plugins/PipeReader.hs | 28 +++ src/Plugins/StdinReader.hs | 33 +++ src/Plugins/Utils.hs | 39 ++++ src/Plugins/XMonadLog.hs | 72 ++++++ src/Plugins/helloworld.config | 12 + src/Runnable.hs | 59 +++++ src/Runnable.hs-boot | 8 + src/StatFS.hsc | 79 +++++++ src/XUtil.hsc | 259 +++++++++++++++++++++ src/Xmobar.hs | 306 +++++++++++++++++++++++++ xmobar.cabal | 3 +- 82 files changed, 4007 insertions(+), 4003 deletions(-) delete mode 100644 Commands.hs delete mode 100644 Config.hs delete mode 100644 IWlib.hsc delete mode 100644 Main.hs delete mode 100644 Parsers.hs delete mode 100644 Plugins.hs delete mode 100644 Plugins/CommandReader.hs delete mode 100644 Plugins/Date.hs delete mode 100644 Plugins/EWMH.hs delete mode 100644 Plugins/HelloWorld.hs delete mode 100644 Plugins/MBox.hs delete mode 100644 Plugins/Mail.hs delete mode 100644 Plugins/Monitors.hs delete mode 100644 Plugins/Monitors/Batt.hs delete mode 100644 Plugins/Monitors/Common.hs delete mode 100644 Plugins/Monitors/CoreCommon.hs delete mode 100644 Plugins/Monitors/CoreTemp.hs delete mode 100644 Plugins/Monitors/Cpu.hs delete mode 100644 Plugins/Monitors/CpuFreq.hs delete mode 100644 Plugins/Monitors/Disk.hs delete mode 100644 Plugins/Monitors/MPD.hs delete mode 100644 Plugins/Monitors/Mem.hs delete mode 100644 Plugins/Monitors/MultiCpu.hs delete mode 100644 Plugins/Monitors/Net.hs delete mode 100644 Plugins/Monitors/Swap.hs delete mode 100644 Plugins/Monitors/Thermal.hs delete mode 100644 Plugins/Monitors/Top.hs delete mode 100644 Plugins/Monitors/Uptime.hs delete mode 100644 Plugins/Monitors/Weather.hs delete mode 100644 Plugins/Monitors/Wireless.hs delete mode 100644 Plugins/PipeReader.hs delete mode 100644 Plugins/StdinReader.hs delete mode 100644 Plugins/Utils.hs delete mode 100644 Plugins/XMonadLog.hs delete mode 100644 Plugins/helloworld.config delete mode 100644 Runnable.hs delete mode 100644 Runnable.hs-boot delete mode 100644 StatFS.hsc delete mode 100644 XUtil.hsc delete mode 100644 Xmobar.hs create mode 100644 src/Commands.hs create mode 100644 src/Config.hs create mode 100644 src/IWlib.hsc create mode 100644 src/Main.hs create mode 100644 src/Parsers.hs create mode 100644 src/Plugins.hs create mode 100644 src/Plugins/CommandReader.hs create mode 100644 src/Plugins/Date.hs create mode 100644 src/Plugins/EWMH.hs create mode 100644 src/Plugins/HelloWorld.hs create mode 100644 src/Plugins/MBox.hs create mode 100644 src/Plugins/Mail.hs create mode 100644 src/Plugins/Monitors.hs create mode 100644 src/Plugins/Monitors/Batt.hs create mode 100644 src/Plugins/Monitors/Common.hs create mode 100644 src/Plugins/Monitors/CoreCommon.hs create mode 100644 src/Plugins/Monitors/CoreTemp.hs create mode 100644 src/Plugins/Monitors/Cpu.hs create mode 100644 src/Plugins/Monitors/CpuFreq.hs create mode 100644 src/Plugins/Monitors/Disk.hs create mode 100644 src/Plugins/Monitors/MPD.hs create mode 100644 src/Plugins/Monitors/Mem.hs create mode 100644 src/Plugins/Monitors/MultiCpu.hs create mode 100644 src/Plugins/Monitors/Net.hs create mode 100644 src/Plugins/Monitors/Swap.hs create mode 100644 src/Plugins/Monitors/Thermal.hs create mode 100644 src/Plugins/Monitors/Top.hs create mode 100644 src/Plugins/Monitors/Uptime.hs create mode 100644 src/Plugins/Monitors/Weather.hs create mode 100644 src/Plugins/Monitors/Wireless.hs create mode 100644 src/Plugins/PipeReader.hs create mode 100644 src/Plugins/StdinReader.hs create mode 100644 src/Plugins/Utils.hs create mode 100644 src/Plugins/XMonadLog.hs create mode 100644 src/Plugins/helloworld.config create mode 100644 src/Runnable.hs create mode 100644 src/Runnable.hs-boot create mode 100644 src/StatFS.hsc create mode 100644 src/XUtil.hsc create mode 100644 src/Xmobar.hs diff --git a/.gitignore b/.gitignore index 5ac7957..83436f2 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,6 @@ /IWlib.hs /StatFS.hs /XUtil.hs +/src/IWlib.hs +/src/StatFS.hs +/src/XUtil.hs diff --git a/Commands.hs b/Commands.hs deleted file mode 100644 index d205dbf..0000000 --- a/Commands.hs +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Commands --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The 'Exec' class and the 'Command' data type. --- --- The 'Exec' class rappresents the executable types, whose constructors may --- appear in the 'Config.commands' field of the 'Config.Config' data type. --- --- The 'Command' data type is for OS commands to be run by xmobar --- ------------------------------------------------------------------------------ - -module Commands - ( Command (..) - , Exec (..) - , tenthSeconds - ) where - -import Prelude hiding (catch) -import Control.Concurrent -import Control.Exception -import Data.Char -import System.Process -import System.Exit -import System.IO (hClose) -import XUtil - -class Show e => Exec e where - alias :: e -> String - alias e = takeWhile (not . isSpace) $ show e - rate :: e -> Int - rate _ = 10 - run :: e -> IO String - run _ = return "" - start :: e -> (String -> IO ()) -> IO () - start e cb = go - where go = do - run e >>= cb - tenthSeconds (rate e) >> go - -data Command = Com Program Args Alias Rate - deriving (Show,Read,Eq) - -type Args = [String] -type Program = String -type Alias = String -type Rate = Int - -instance Exec Command where - alias (Com p _ a _) - | p /= "" = if a == "" then p else a - | otherwise = "" - start (Com prog args _ r) cb = if r > 0 then go else exec - where go = exec >> tenthSeconds r >> go - exec = do - (i,o,e,p) <- runInteractiveCommand (unwords (prog:args)) - exit <- waitForProcess p - let closeHandles = hClose o >> hClose i >> hClose e - case exit of - ExitSuccess -> do - str <- catch (hGetLineSafe o) - (\(SomeException _) -> return "") - closeHandles - cb str - _ -> do closeHandles - cb $ "Could not execute command " ++ prog - - --- | Work around to the Int max bound: since threadDelay takes an Int, it --- is not possible to set a thread delay grater than about 45 minutes. --- With a little recursion we solve the problem. -tenthSeconds :: Int -> IO () -tenthSeconds s | s >= x = do threadDelay y - tenthSeconds (x - s) - | otherwise = threadDelay (s * 100000) - where y = maxBound :: Int - x = y `div` 100000 diff --git a/Config.hs b/Config.hs deleted file mode 100644 index 6eb55a0..0000000 --- a/Config.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE CPP, TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Config --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The configuration module of Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Config - ( -- * Configuration - -- $config - Config (..) - , XPosition (..), Align (..), Border(..) - , defaultConfig - , runnableTypes - ) where - -import Commands -import {-# SOURCE #-} Runnable -import Plugins.Monitors -import Plugins.Date -import Plugins.PipeReader -import Plugins.CommandReader -import Plugins.StdinReader -import Plugins.XMonadLog -import Plugins.EWMH - -#ifdef INOTIFY -import Plugins.Mail -import Plugins.MBox -#endif - --- $config --- Configuration data type and default configuration - --- | The configuration data type -data Config = - Config { font :: String -- ^ Font - , bgColor :: String -- ^ Backgroud color - , fgColor :: String -- ^ Default font color - , position :: XPosition -- ^ Top Bottom or Static - , border :: Border -- ^ NoBorder TopB BottomB or FullB - , borderColor :: String -- ^ Border color - , lowerOnStart :: Bool -- ^ Lower to the bottom of the - -- window stack on initialization - , commands :: [Runnable] -- ^ For setting the command, the command arguments - -- and refresh rate for the programs to run (optional) - , sepChar :: String -- ^ The character to be used for indicating - -- commands in the output template (default '%') - , alignSep :: String -- ^ Separators for left, center and right text alignment - , template :: String -- ^ The output template - } deriving (Read) - -data XPosition = Top - | TopW Align Int - | TopSize Align Int Int - | Bottom - | BottomW Align Int - | BottomSize Align Int Int - | Static {xpos, ypos, width, height :: Int} - | OnScreen Int XPosition - deriving ( Read, Eq ) - -data Align = L | R | C deriving ( Read, Eq ) - -data Border = NoBorder - | TopB - | BottomB - | FullB - | TopBM Int - | BottomBM Int - | FullBM Int - deriving ( Read, Eq ) - --- | The default configuration values -defaultConfig :: Config -defaultConfig = - Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , bgColor = "#000000" - , fgColor = "#BFBFBF" - , position = Top - , border = NoBorder - , borderColor = "#BFBFBF" - , lowerOnStart = True - , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 - , Run StdinReader] - , sepChar = "%" - , alignSep = "}{" - , template = "%StdinReader% }{ %uname% * %theDate%" - } - - --- | An alias for tuple types that is more convenient for long lists. -type a :*: b = (a, b) -infixr :*: - --- | This is the list of types that can be hidden inside --- 'Runnable.Runnable', the existential type that stores all commands --- to be executed by Xmobar. It is used by 'Runnable.readRunnable' in --- the 'Runnable.Runnable' Read instance. To install a plugin just add --- the plugin's type to the list of types (separated by ':*:') appearing in --- this function's type signature. -runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: -#ifdef INOTIFY - Mail :*: MBox :*: -#endif - () -runnableTypes = undefined diff --git a/IWlib.hsc b/IWlib.hsc deleted file mode 100644 index 5f7754d..0000000 --- a/IWlib.hsc +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : IWlib --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A partial binding to iwlib --- ------------------------------------------------------------------------------ - -{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} - - -module IWlib (WirelessInfo(..), getWirelessInfo) where - -import Foreign -import Foreign.C.Types -import Foreign.C.String - -data WirelessInfo = WirelessInfo { wiEssid :: String, wiQuality :: Int } - deriving Show - -#include - -data WCfg -data WStats -data WRange - -foreign import ccall "iwlib.h iw_sockets_open" - c_iw_open :: IO CInt - -foreign import ccall "unistd.h close" - c_iw_close :: CInt -> IO () - -foreign import ccall "iwlib.h iw_get_basic_config" - c_iw_basic_config :: CInt -> CString -> Ptr WCfg -> IO CInt - -foreign import ccall "iwlib.h iw_get_stats" - c_iw_stats :: CInt -> CString -> Ptr WStats -> Ptr WRange -> CInt -> IO CInt - -foreign import ccall "iwlib.h iw_get_range_info" - c_iw_range :: CInt -> CString -> Ptr WRange -> IO CInt - -getWirelessInfo :: String -> IO WirelessInfo -getWirelessInfo iface = - allocaBytes (#size struct wireless_config) $ \wc -> - allocaBytes (#size struct iw_statistics) $ \stats -> - allocaBytes (#size struct iw_range) $ \rng -> - withCString iface $ \istr -> do - i <- c_iw_open - bcr <- c_iw_basic_config i istr wc - str <- c_iw_stats i istr stats rng 1 - rgr <- c_iw_range i istr rng - c_iw_close i - if (bcr < 0) then return WirelessInfo { wiEssid = "", wiQuality = 0 } else - do hase <- (#peek struct wireless_config, has_essid) wc :: IO CInt - eon <- (#peek struct wireless_config, essid_on) wc :: IO CInt - essid <- if hase /= 0 && eon /= 0 then - do let e = (#ptr struct wireless_config, essid) wc - peekCString e - else return "" - q <- if str >= 0 && rgr >=0 then - do qualv <- xqual $ (#ptr struct iw_statistics, qual) stats - mv <- xqual $ (#ptr struct iw_range, max_qual) rng - let mxv = if mv /= 0 then fromIntegral mv else 1 - return $ fromIntegral qualv / mxv - else return 0 - let qv = round (100 * (q :: Double)) - return $ WirelessInfo { wiEssid = essid, wiQuality = min 100 qv } - where xqual p = let qp = (#ptr struct iw_param, value) p in - (#peek struct iw_quality, qual) qp :: IO CChar diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 2719a79..0000000 --- a/Main.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Main --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The main module of Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Main ( -- * Main Stuff - -- $main - main - , readConfig - , readDefaultConfig - ) where - -import Xmobar -import Parsers -import Config -import XUtil - -import Data.List (intercalate) - -import Paths_xmobar (version) -import Data.IORef -import Data.Version (showVersion) -import Graphics.X11.Xlib -import System.Console.GetOpt -import System.Exit -import System.Environment -import System.Posix.Files -import Control.Monad (unless) - --- $main - --- | The main entry point -main :: IO () -main = do - d <- openDisplay "" - args <- getArgs - (o,file) <- getOpts args - (c,defaultings) <- case file of - [cfgfile] -> readConfig cfgfile - _ -> readDefaultConfig - - unless (null defaultings) $ putStrLn $ "Fields missing from config defaulted: " - ++ intercalate "," defaultings - - -- listen for ConfigureEvents on the root window, for xrandr support: - rootw <- rootWindow d (defaultScreen d) - selectInput d rootw structureNotifyMask - - civ <- newIORef c - doOpts civ o - conf <- readIORef civ - fs <- initFont d (font conf) - cl <- parseTemplate conf (template conf) - vars <- mapM startCommand cl - (r,w) <- createWin d fs conf - eventLoop (XConf d r w fs conf) vars - --- | Reads the configuration files or quits with an error -readConfig :: FilePath -> IO (Config,[String]) -readConfig f = do - file <- io $ fileExist f - s <- io $ if file then readFileSafe f else error $ f ++ ": file not found!\n" ++ usage - either (\err -> error $ f ++ ": configuration file contains errors at:\n" ++ show err) - return $ parseConfig s - --- | Read default configuration file or load the default config -readDefaultConfig :: IO (Config,[String]) -readDefaultConfig = do - home <- io $ getEnv "HOME" - let path = home ++ "/.xmobarrc" - f <- io $ fileExist path - if f then readConfig path else return (defaultConfig,[]) - -data Opts = Help - | Version - | Font String - | BgColor String - | FgColor String - | T - | B - | AlignSep String - | Commands String - | SepChar String - | Template String - | OnScr String - deriving Show - -options :: [OptDescr Opts] -options = - [ Option ['h','?' ] ["help" ] (NoArg Help ) "This help" - , Option ['V' ] ["version" ] (NoArg Version ) "Show version information" - , Option ['f' ] ["font" ] (ReqArg Font "font name") "The font name" - , Option ['B' ] ["bgcolor" ] (ReqArg BgColor "bg color" ) "The background color. Default black" - , Option ['F' ] ["fgcolor" ] (ReqArg FgColor "fg color" ) "The foreground color. Default grey" - , Option ['o' ] ["top" ] (NoArg T ) "Place xmobar at the top of the screen" - , Option ['b' ] ["bottom" ] (NoArg B ) "Place xmobar at the bottom of the screen" - , Option ['a' ] ["alignsep" ] (ReqArg AlignSep "alignsep" ) "Separators for left, center and right text\nalignment. Default: '}{'" - , Option ['s' ] ["sepchar" ] (ReqArg SepChar "char" ) "The character used to separate commands in\nthe output template. Default '%'" - , Option ['t' ] ["template" ] (ReqArg Template "template" ) "The output template" - , Option ['c' ] ["commands" ] (ReqArg Commands "commands" ) "The list of commands to be executed" - , Option ['x' ] ["screen" ] (ReqArg OnScr "screen" ) "On which X screen number to start" - ] - -getOpts :: [String] -> IO ([Opts], [String]) -getOpts argv = - case getOpt Permute options argv of - (o,n,[]) -> return (o,n) - (_,_,errs) -> error (concat errs ++ usage) - -usage :: String -usage = (usageInfo header options) ++ footer - where header = "Usage: xmobar [OPTION...] [FILE]\nOptions:" - footer = "\nMail bug reports and suggestions to " ++ mail ++ "\n" - -info :: String -info = "xmobar " ++ showVersion version - ++ "\n (C) 2007 - 2010 Andrea Rossato " - ++ "\n (C) 2010 Jose A Ortega Ruiz\n " - ++ mail ++ "\n" ++ license - -mail :: String -mail = "" - -license :: String -license = "\nThis program is distributed in the hope that it will be useful,\n" ++ - "but WITHOUT ANY WARRANTY; without even the implied warranty of\n" ++ - "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n" ++ - "See the License for more details." - -doOpts :: IORef Config -> [Opts] -> IO () -doOpts _ [] = return () -doOpts conf (o:oo) = - case o of - Help -> putStr usage >> exitWith ExitSuccess - Version -> putStrLn info >> exitWith ExitSuccess - Font s -> modifyIORef conf (\c -> c { font = s }) >> go - BgColor s -> modifyIORef conf (\c -> c { bgColor = s }) >> go - FgColor s -> modifyIORef conf (\c -> c { fgColor = s }) >> go - T -> modifyIORef conf (\c -> c { position = Top }) >> go - B -> modifyIORef conf (\c -> c { position = Bottom}) >> go - AlignSep s -> modifyIORef conf (\c -> c { alignSep = s }) >> go - SepChar s -> modifyIORef conf (\c -> c { sepChar = s }) >> go - Template s -> modifyIORef conf (\c -> c { template = s }) >> go - OnScr n -> modifyIORef conf (\c -> c { position = OnScreen (read n) $ position c }) >> go - Commands s -> case readCom s of - Right x -> modifyIORef conf (\c -> c { commands = x }) >> go - Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) - where readCom str = - case readStr str of - [x] -> Right x - _ -> Left "xmobar: cannot read list of commands specified with the -c option\n" - readStr str = - [x | (x,t) <- reads str, ("","") <- lex t] - go = doOpts conf oo diff --git a/Parsers.hs b/Parsers.hs deleted file mode 100644 index 1450a0e..0000000 --- a/Parsers.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- Parsers needed for Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Parsers - ( parseString - , parseTemplate - , parseConfig - ) where - -import Config -import Runnable -import Commands - -import qualified Data.Map as Map -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Perm - --- | Runs the string parser -parseString :: Config -> String -> IO [(String, String)] -parseString c s = - case parse (stringParser (fgColor c)) "" s of - Left _ -> return [("Could not parse string: " ++ s, fgColor c)] - Right x -> return (concat x) - --- | Gets the string and combines the needed parsers -stringParser :: String -> Parser [[(String, String)]] -stringParser c = manyTill (textParser c <|> colorParser) eof - --- | Parses a maximal string without color markup. -textParser :: String -> Parser [(String, String)] -textParser c = do s <- many1 $ - noneOf "<" <|> - ( try $ notFollowedBy' (char '<') - (string "fc=" <|> string "/fc>" ) ) - return [(s, c)] - --- | Wrapper for notFollowedBy that returns the result of the first parser. --- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy --- accepts only parsers with return type Char. -notFollowedBy' :: Parser a -> Parser b -> Parser a -notFollowedBy' p e = do x <- p - notFollowedBy $ try (e >> return '*') - return x - --- | Parsers a string wrapped in a color specification. -colorParser :: Parser [(String, String)] -colorParser = do - c <- between (string "") colors - s <- manyTill (textParser c <|> colorParser) (try $ string "") - return (concat s) - --- | Parses a color specification (hex or named) -colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char '#') - --- | Parses the output template string -templateStringParser :: Config -> Parser (String,String,String) -templateStringParser c = do - s <- allTillSep c - com <- templateCommandParser c - ss <- allTillSep c - return (com, s, ss) - --- | Parses the command part of the template string -templateCommandParser :: Config -> Parser String -templateCommandParser c = - let chr = char . head . sepChar - in between (chr c) (chr c) (allTillSep c) - --- | Combines the template parsers -templateParser :: Config -> Parser [(String,String,String)] -templateParser = many . templateStringParser - --- | Actually runs the template parsers -parseTemplate :: Config -> String -> IO [(Runnable,String,String)] -parseTemplate c s = - do str <- case parse (templateParser c) "" s of - Left _ -> return [("","","")] - Right x -> return x - let cl = map alias (commands c) - m = Map.fromList $ zip cl (commands c) - return $ combine c m str - --- | Given a finite "Map" and a parsed template produce the resulting --- output string. -combine :: Config -> Map.Map String Runnable -> [(String, String, String)] -> [(Runnable,String,String)] -combine _ _ [] = [] -combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs - where com = Map.findWithDefault dflt ts m - dflt = Run $ Com ts [] [] 10 - -allTillSep :: Config -> Parser String -allTillSep = many . noneOf . sepChar - -stripComments :: String -> String -stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines - where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else "" - strip m ('\\':xss) = case xss of - '\\':xs -> '\\' : strip m xs - _ -> strip m $ drop 1 xss - strip m ('"':xs) = '"': strip (not m) xs - strip m (x:xs) = x : strip m xs - strip _ [] = [] - --- | Parse the config, logging a list of fields that were missing and replaced --- by the default definition. -parseConfig :: String -> Either ParseError (Config,[String]) -parseConfig = runParser parseConf fields "Config" . stripComments - where - parseConf = do - many space - sepEndSpc ["Config","{"] - x <- perms - eof - s <- getState - return (x,s) - - perms = permute $ Config - <$?> pFont <|?> pBgColor - <|?> pFgColor <|?> pPosition - <|?> pBorder <|?> pBdColor - <|?> pLowerOnStart <|?> pCommands - <|?> pSepChar <|?> pAlignSep - <|?> pTemplate - - fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" - , "border", "borderColor" ,"template", "position" - , "lowerOnStart", "commands"] - pFont = strField font "font" - pBgColor = strField bgColor "bgColor" - pFgColor = strField fgColor "fgColor" - pBdColor = strField borderColor "borderColor" - pSepChar = strField sepChar "sepChar" - pAlignSep = strField alignSep "alignSep" - pTemplate = strField template "template" - - pPosition = field position "position" $ tillFieldEnd >>= read' "position" - pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart" - pBorder = field border "border" $ tillFieldEnd >>= read' "border" - pCommands = field commands "commands" $ readCommands - - staticPos = do string "Static" - wrapSkip (string "{") - p <- many (noneOf "}") - wrapSkip (string "}") - string "," - return ("Static {" ++ p ++ "}") - tillFieldEnd = staticPos <|> many (noneOf ",}\n\r") - - commandsEnd = wrapSkip (string "]") >> oneOf "}," - readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]" - - strField e n = field e n . between (strDel "start" n) (strDel "end" n) . many $ noneOf "\"\n\r" - strDel t n = char '"' strErr t n - strErr t n = "the " ++ t ++ " of the string field " ++ n ++ " - a double quote (\")." - - wrapSkip x = many space >> x >>= \r -> many space >> return r - sepEndSpc = mapM_ (wrapSkip . try . string) - fieldEnd = many $ space <|> oneOf ",}" - field e n c = (,) (e defaultConfig) $ - updateState (filter (/= n)) >> sepEndSpc [n,"="] >> - wrapSkip c >>= \r -> fieldEnd >> return r - - read' d s = case reads s of - [(x, _)] -> return x - _ -> fail $ "error reading the " ++ d ++ " field: " ++ s - -commandsErr :: String -commandsErr = "commands: this usually means that a command could not be parsed.\n" ++ - "The error could be located at the begining of the command which follows the offending one." - diff --git a/Plugins.hs b/Plugins.hs deleted file mode 100644 index 4255244..0000000 --- a/Plugins.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Plugins --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- This module exports the API for plugins. --- --- Have a look at Plugins\/HelloWorld.hs --- ------------------------------------------------------------------------------ - -module Plugins - ( Exec (..) - , tenthSeconds - , readFileSafe - , hGetLineSafe - ) where - -import Commands -import XUtil diff --git a/Plugins/CommandReader.hs b/Plugins/CommandReader.hs deleted file mode 100644 index 7c7c92d..0000000 --- a/Plugins/CommandReader.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.CommandReader --- Copyright : (c) John Goerzen --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from external commands --- note: stderr is lost here --- ------------------------------------------------------------------------------ - -module Plugins.CommandReader where - -import System.IO -import Plugins -import System.Process(runInteractiveCommand, getProcessExitCode) - -data CommandReader = CommandReader String String - deriving (Read, Show) - -instance Exec CommandReader where - alias (CommandReader _ a) = a - start (CommandReader p _) cb = do - (hstdin, hstdout, hstderr, ph) <- runInteractiveCommand p - hClose hstdin - hClose hstderr - hSetBinaryMode hstdout False - hSetBuffering hstdout LineBuffering - forever ph (hGetLineSafe hstdout >>= cb) - where forever ph a = - do a - ec <- getProcessExitCode ph - case ec of - Nothing -> forever ph a - Just _ -> cb "EXITED" diff --git a/Plugins/Date.hs b/Plugins/Date.hs deleted file mode 100644 index bfcb132..0000000 --- a/Plugins/Date.hs +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Date --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A date plugin for Xmobar --- --- Usage example: in template put --- --- > Run Date "%a %b %_d %Y %H:%M:%S" "Mydate" 10 --- ------------------------------------------------------------------------------ - -module Plugins.Date (Date(..)) where - -import Plugins - -import System.Locale -import System.Time - -data Date = Date String String Int - deriving (Read, Show) - -instance Exec Date where - alias (Date _ a _) = a - run (Date f _ _) = date f - rate (Date _ _ r) = r - -date :: String -> IO String -date format = do - t <- toCalendarTime =<< getClockTime - return $ formatCalendarTime defaultTimeLocale format t diff --git a/Plugins/EWMH.hs b/Plugins/EWMH.hs deleted file mode 100644 index d5b70cb..0000000 --- a/Plugins/EWMH.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------ --- | --- Module : Plugins.EWMH --- Copyright : (c) Spencer Janssen --- License : BSD-style (see LICENSE) --- --- Maintainer : Spencer Janssen --- Stability : unstable --- Portability : unportable --- --- An experimental plugin to display EWMH pager information --- ------------------------------------------------------------------------------ - -module Plugins.EWMH (EWMH(..)) where - -import Control.Monad.State -import Control.Monad.Reader -import Graphics.X11 hiding (Modifier, Color) -import Graphics.X11.Xlib.Extras -import Plugins -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar, CLong) -import XUtil (nextEvent') - -import Data.List (intersperse, intercalate) - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - - -data EWMH = EWMH | EWMHFMT Component deriving (Read, Show) - -instance Exec EWMH where - alias EWMH = "EWMH" - - start ew cb = allocaXEvent $ \ep -> execM $ do - d <- asks display - r <- asks root - - liftIO xSetErrorHandler - - liftIO $ selectInput d r propertyChangeMask - handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers - mapM_ ((=<< asks root) . snd) handlers' - - forever $ do - liftIO . cb . fmtOf ew =<< get - liftIO $ nextEvent' d ep - e <- liftIO $ getEvent ep - case e of - PropertyEvent { ev_atom = a, ev_window = w } -> do - case lookup a handlers' of - Just f -> f w - _ -> return () - _ -> return () - - return () - -defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty] - , Layout - , Color "#00ee00" "" :$ Short 120 :$ WindowName] - -fmtOf EWMH = flip fmt defaultPP -fmtOf (EWMHFMT f) = flip fmt f - -sep :: [a] -> [[a]] -> [a] -sep x xs = intercalate x $ filter (not . null) xs - -fmt :: EwmhState -> Component -> String -fmt e (Text s) = s -fmt e (l :+ r) = fmt e l ++ fmt e r -fmt e (m :$ r) = modifier m $ fmt e r -fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs -fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e) -fmt e Layout = layout e -fmt e (Workspaces opts) = sep " " - [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as] - | (n, as) <- attrs] - where - stats i = [ (Current, i == currentDesktop e) - , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e) - -- TODO for visible , (Visibl - ] - attrs :: [(String, [WsType])] - attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)] - nonEmptys = Set.unions . map desktops . Map.elems $ clients e - -modifier :: Modifier -> (String -> String) -modifier Hide = const "" -modifier (Color fg bg) = \x -> concat ["", x, ""] -modifier (Short n) = take n -modifier (Wrap l r) = \x -> l ++ x ++ r - -data Component = Text String - | Component :+ Component - | Modifier :$ Component - | Sep Component [Component] - | WindowName - | Layout - | Workspaces [WsOpt] - deriving (Read, Show) - -infixr 0 :$ -infixr 5 :+ - -data Modifier = Hide - | Color String String - | Short Int - | Wrap String String - deriving (Read, Show) - -data WsOpt = Modifier :% WsType - | WSep Component - deriving (Read, Show) -infixr 0 :% - -data WsType = Current | Empty | Visible - deriving (Read, Show, Eq) - -data EwmhConf = C { root :: Window - , display :: Display } - -data EwmhState = S { currentDesktop :: CLong - , activeWindow :: Window - , desktopNames :: [String] - , layout :: String - , clients :: Map Window Client } - deriving Show - -data Client = Cl { windowName :: String - , desktops :: Set CLong } - deriving Show - -getAtom :: String -> M Atom -getAtom s = do - d <- asks display - liftIO $ internAtom d s False - -windowProperty32 :: String -> Window -> M (Maybe [CLong]) -windowProperty32 s w = do - (C {display}) <- ask - a <- getAtom s - liftIO $ getWindowProperty32 display a w - -windowProperty8 :: String -> Window -> M (Maybe [CChar]) -windowProperty8 s w = do - (C {display}) <- ask - a <- getAtom s - liftIO $ getWindowProperty8 display a w - -initialState :: EwmhState -initialState = S 0 0 [] [] Map.empty - -initialClient :: Client -initialClient = Cl "" Set.empty - -handlers, clientHandlers :: [(String, Updater)] -handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop) - , ("_NET_DESKTOP_NAMES", updateDesktopNames ) - , ("_NET_ACTIVE_WINDOW", updateActiveWindow) - , ("_NET_CLIENT_LIST", updateClientList) - ] ++ clientHandlers - -clientHandlers = [ ("_NET_WM_NAME", updateName) - , ("_NET_WM_DESKTOP", updateDesktop) ] - -newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a) - deriving (Monad, Functor, MonadIO, MonadReader EwmhConf, MonadState EwmhState) - -execM :: M a -> IO a -execM (M m) = do - d <- openDisplay "" - r <- rootWindow d (defaultScreen d) - let conf = C r d - evalStateT (runReaderT m (C r d)) initialState - -type Updater = Window -> M () - -updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater -updateCurrentDesktop _ = do - (C {root}) <- ask - mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root - case mwp of - Just [x] -> modify (\s -> s { currentDesktop = x }) - _ -> return () - -updateActiveWindow _ = do - (C {root}) <- ask - mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root - case mwp of - Just [x] -> modify (\s -> s { activeWindow = fromIntegral x }) - _ -> return () - -updateDesktopNames _ = do - (C {root}) <- ask - mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root - case mwp of - Just xs -> modify (\s -> s { desktopNames = parse xs }) - _ -> return () - where - dropNull ('\0':xs) = xs - dropNull xs = xs - - split [] = [] - split xs = case span (/= '\0') xs of - (x, ys) -> x : split (dropNull ys) - parse = split . decodeCChar - -updateClientList _ = do - (C {root}) <- ask - mwp <- windowProperty32 "_NET_CLIENT_LIST" root - case mwp of - Just xs -> do - cl <- gets clients - let cl' = Map.fromList $ map (flip (,) initialClient . fromIntegral) xs - dels = Map.difference cl cl' - new = Map.difference cl' cl - modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'}) - mapM_ unmanage (map fst $ Map.toList dels) - mapM_ listen (map fst $ Map.toList cl') - mapM_ update (map fst $ Map.toList new) - _ -> return () - where - unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0 - listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask - update w = mapM_ (($ w) . snd) clientHandlers - -modifyClient :: Window -> (Client -> Client) -> M () -modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s }) - where - f' Nothing = Just $ f initialClient - f' (Just x) = Just $ f x - -updateName w = do - mwp <- windowProperty8 "_NET_WM_NAME" w - case mwp of - Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs }) - _ -> return () - -updateDesktop w = do - mwp <- windowProperty32 "_NET_WM_DESKTOP" w - case mwp of - Just x -> modifyClient w (\c -> c { desktops = Set.fromList x }) - _ -> return () - -decodeCChar :: [CChar] -> String -#ifdef UTF8 -#undef UTF8 -decodeCChar = UTF8.decode . map fromIntegral -#define UTF8 -#else -decodeCChar = map (toEnum . fromIntegral) -#endif diff --git a/Plugins/HelloWorld.hs b/Plugins/HelloWorld.hs deleted file mode 100644 index df5cff6..0000000 --- a/Plugins/HelloWorld.hs +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.HelloWorld --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin example for Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Plugins.HelloWorld where - -import Plugins - -data HelloWorld = HelloWorld - deriving (Read, Show) - -instance Exec HelloWorld where - alias HelloWorld = "helloWorld" - run HelloWorld = return "Hello World!!" diff --git a/Plugins/MBox.hs b/Plugins/MBox.hs deleted file mode 100644 index 65a8bb3..0000000 --- a/Plugins/MBox.hs +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.MBox --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin for checking mail in mbox files. --- ------------------------------------------------------------------------------ - -module Plugins.MBox (MBox(..)) where - -import Prelude hiding (catch) -import Plugins -import Plugins.Utils (changeLoop, expandHome) - -import Control.Monad (when) -import Control.Concurrent.STM -import Control.Exception (SomeException, handle, evaluate) - -import System.Console.GetOpt -import System.Directory (doesFileExist) -import System.FilePath (()) -import System.INotify (Event(..), EventVariety(..), initINotify, addWatch) - -import qualified Data.ByteString.Lazy.Char8 as B - -data Options = Options - { oAll :: Bool - , oUniq :: Bool - , oDir :: FilePath - , oPrefix :: String - , oSuffix :: String - } - -defaults :: Options -defaults = Options { - oAll = False, oUniq = False, oDir = "", oPrefix = "", oSuffix = "" - } - -options :: [OptDescr (Options -> Options)] -options = - [ Option "a" ["all"] (NoArg (\o -> o { oAll = True })) "" - , Option "u" [] (NoArg (\o -> o { oUniq = True })) "" - , Option "d" ["dir"] (ReqArg (\x o -> o { oDir = x }) "") "" - , Option "p" ["prefix"] (ReqArg (\x o -> o { oPrefix = x }) "") "" - , Option "s" ["suffix"] (ReqArg (\x o -> o { oSuffix = x }) "") "" - ] - -parseOptions :: [String] -> IO Options -parseOptions args = - case getOpt Permute options args of - (o, _, []) -> return $ foldr id defaults o - (_, _, errs) -> ioError . userError $ concat errs - --- | A list of display names, paths to mbox files and display colours, --- followed by a list of options. -data MBox = MBox [(String, FilePath, String)] [String] String - deriving (Read, Show) - -instance Exec MBox where - alias (MBox _ _ a) = a - start (MBox boxes args _) cb = do - - opts <- parseOptions args - let showAll = oAll opts - prefix = oPrefix opts - suffix = oSuffix opts - uniq = oUniq opts - names = map (\(t, _, _) -> t) boxes - colors = map (\(_, _, c) -> c) boxes - extractPath (_, f, _) = expandHome $ oDir opts f - events = [CloseWrite] - - i <- initINotify - vs <- mapM (\b -> do - f <- extractPath b - exists <- doesFileExist f - n <- if exists then countMails f else return (-1) - v <- newTVarIO (f, n) - when exists $ - addWatch i events f (handleNotification v) >> return () - return v) - boxes - - changeLoop (mapM (fmap snd . readTVar) vs) $ \ns -> - let s = unwords [ showC uniq m n c | (m, n, c) <- zip3 names ns colors - , showAll || n > 0 ] - in cb (if null s then "" else prefix ++ s ++ suffix) - -showC :: Bool -> String -> Int -> String -> String -showC u m n c = - if c == "" then msg else "" ++ msg ++ "" - where msg = m ++ if not u || n > 1 then show n else "" - -countMails :: FilePath -> IO Int -countMails f = - handle ((\_ -> evaluate 0) :: SomeException -> IO Int) - (do txt <- B.readFile f - evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt) - where from = B.pack "From " - -handleNotification :: TVar (FilePath, Int) -> Event -> IO () -handleNotification v _ = do - (p, _) <- atomically $ readTVar v - n <- countMails p - atomically $ writeTVar v (p, n) diff --git a/Plugins/Mail.hs b/Plugins/Mail.hs deleted file mode 100644 index 38cdaae..0000000 --- a/Plugins/Mail.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Mail --- Copyright : (c) Spencer Janssen --- License : BSD-style (see LICENSE) --- --- Maintainer : Spencer Janssen --- Stability : unstable --- Portability : unportable --- --- A plugin for checking mail. --- ------------------------------------------------------------------------------ - -module Plugins.Mail where - -import Prelude hiding (catch) -import Plugins -import Plugins.Utils (expandHome, changeLoop) - -import Control.Monad -import Control.Concurrent.STM - -import System.Directory -import System.FilePath -import System.INotify - -import Data.List (isPrefixOf) -import Data.Set (Set) -import qualified Data.Set as S - --- | A list of mail box names and paths to maildirs. -data Mail = Mail [(String, FilePath)] - deriving (Read, Show) - -instance Exec Mail where - start (Mail ms) cb = do - vs <- mapM (const $ newTVarIO S.empty) ms - - let ts = map fst ms - rs = map (( "new") . snd) ms - ev = [Move, MoveIn, MoveOut, Create, Delete] - - ds <- mapM expandHome rs - i <- initINotify - zipWithM_ (\d v -> addWatch i ev d (handle v)) ds vs - - forM_ (zip ds vs) $ \(d, v) -> do - s <- fmap (S.fromList . filter (not . isPrefixOf ".")) - $ getDirectoryContents d - atomically $ modifyTVar v (S.union s) - - changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns -> - cb . unwords $ [m ++ ":" ++ show n - | (m, n) <- zip ts ns - , n /= 0 ] - -modifyTVar :: TVar a -> (a -> a) -> STM () -modifyTVar v f = readTVar v >>= writeTVar v . f - -handle :: TVar (Set String) -> Event -> IO () -handle v e = atomically $ modifyTVar v $ case e of - Created {} -> create - MovedIn {} -> create - Deleted {} -> delete - MovedOut {} -> delete - _ -> id - where - delete = S.delete (filePath e) - create = S.insert (filePath e) diff --git a/Plugins/Monitors.hs b/Plugins/Monitors.hs deleted file mode 100644 index 9887d74..0000000 --- a/Plugins/Monitors.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Plugins.Monitors --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The system monitor plugin for Xmobar. --- ------------------------------------------------------------------------------ - -module Plugins.Monitors where - -import Plugins - -import Plugins.Monitors.Common ( runM ) -import Plugins.Monitors.Weather -import Plugins.Monitors.Net -import Plugins.Monitors.Mem -import Plugins.Monitors.Swap -import Plugins.Monitors.Cpu -import Plugins.Monitors.MultiCpu -import Plugins.Monitors.Batt -import Plugins.Monitors.Thermal -import Plugins.Monitors.CpuFreq -import Plugins.Monitors.CoreTemp -import Plugins.Monitors.Disk -import Plugins.Monitors.Top -import Plugins.Monitors.Uptime -#ifdef IWLIB -import Plugins.Monitors.Wireless -#endif -#ifdef LIBMPD -import Plugins.Monitors.MPD -#endif - -data Monitors = Weather Station Args Rate - | Network Interface Args Rate - | Memory Args Rate - | Swap Args Rate - | Cpu Args Rate - | MultiCpu Args Rate - | Battery Args Rate - | BatteryP [String] Args Rate - | DiskU DiskSpec Args Rate - | DiskIO DiskSpec Args Rate - | Thermal Zone Args Rate - | CpuFreq Args Rate - | CoreTemp Args Rate - | TopProc Args Rate - | TopMem Args Rate - | Uptime Args Rate -#ifdef IWLIB - | Wireless Interface Args Rate -#endif -#ifdef LIBMPD - | MPD Args Rate -#endif - deriving (Show,Read,Eq) - -type Args = [String] -type Program = String -type Alias = String -type Station = String -type Zone = String -type Interface = String -type Rate = Int -type DiskSpec = [(String, String)] - -instance Exec Monitors where - alias (Weather s _ _) = s - alias (Network i _ _) = i - alias (Thermal z _ _) = z - alias (Memory _ _) = "memory" - alias (Swap _ _) = "swap" - alias (Cpu _ _) = "cpu" - alias (MultiCpu _ _) = "multicpu" - alias (Battery _ _) = "battery" - alias (BatteryP _ _ _)= "battery" - alias (CpuFreq _ _) = "cpufreq" - alias (TopProc _ _) = "top" - alias (TopMem _ _) = "topmem" - alias (CoreTemp _ _) = "coretemp" - alias (DiskU _ _ _) = "disku" - alias (DiskIO _ _ _) = "diskio" - alias (Uptime _ _) = "uptime" -#ifdef IWLIB - alias (Wireless i _ _) = i ++ "wi" -#endif -#ifdef LIBMPD - alias (MPD _ _) = "mpd" -#endif - start (Weather s a r) = runM (a ++ [s]) weatherConfig runWeather r - start (Network i a r) = runM (a ++ [i]) netConfig runNet r - start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r - start (Memory a r) = runM a memConfig runMem r - start (Swap a r) = runM a swapConfig runSwap r - start (Cpu a r) = runM a cpuConfig runCpu r - start (MultiCpu a r) = runM a multiCpuConfig runMultiCpu r - start (Battery a r) = runM a battConfig runBatt r - start (BatteryP s a r) = runM a battConfig (runBatt' s) r - start (CpuFreq a r) = runM a cpuFreqConfig runCpuFreq r - start (CoreTemp a r) = runM a coreTempConfig runCoreTemp r - start (DiskU s a r) = runM a diskUConfig (runDiskU s) r - start (DiskIO s a r) = runM a diskIOConfig (runDiskIO s) r - start (TopMem a r) = runM a topMemConfig runTopMem r - start (Uptime a r) = runM a uptimeConfig runUptime r - start (TopProc a r) = startTop a r -#ifdef IWLIB - start (Wireless i a r) = runM (a ++ [i]) wirelessConfig runWireless r -#endif -#ifdef LIBMPD - start (MPD a r) = runM a mpdConfig runMPD r -#endif diff --git a/Plugins/Monitors/Batt.hs b/Plugins/Monitors/Batt.hs deleted file mode 100644 index 11b2d6c..0000000 --- a/Plugins/Monitors/Batt.hs +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Batt --- Copyright : (c) Andrea Rossato, 2010 Petr Rockai, 2010 Jose A Ortega --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A battery monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where - -import qualified Data.ByteString.Lazy.Char8 as B -import Plugins.Monitors.Common -import System.Posix.Files (fileExist) -import System.Console.GetOpt - -data BattOpts = BattOpts - { onString :: String - , offString :: String - , posColor :: Maybe String - , lowWColor :: Maybe String - , mediumWColor :: Maybe String - , highWColor :: Maybe String - , lowThreshold :: Float - , highThreshold :: Float - } - -defaultOpts :: BattOpts -defaultOpts = BattOpts - { onString = "On" - , offString = "Off" - , posColor = Nothing - , lowWColor = Nothing - , mediumWColor = Nothing - , highWColor = Nothing - , lowThreshold = -12 - , highThreshold = -10 - } - -options :: [OptDescr (BattOpts -> BattOpts)] -options = - [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" - , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") "" - , Option "p" ["positive"] (ReqArg (\x o -> o { posColor = Just x }) "") "" - , Option "l" ["low"] (ReqArg (\x o -> o { lowWColor = Just x }) "") "" - , Option "m" ["medium"] (ReqArg (\x o -> o { mediumWColor = Just x }) "") "" - , Option "h" ["high"] (ReqArg (\x o -> o { highWColor = Just x }) "") "" - , Option "L" ["lowt"] (ReqArg (\x o -> o { lowThreshold = read x }) "") "" - , Option "H" ["hight"] (ReqArg (\x o -> o { highThreshold = read x }) "") "" - ] - -parseOpts :: [String] -> IO BattOpts -parseOpts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs - -data Result = Result Float Float Float String | NA - -base :: String -base = "/sys/class/power_supply" - -battConfig :: IO MConfig -battConfig = mkMConfig - "Batt: , % / " -- template - ["leftbar", "left", "acstatus", "timeleft", "watts"] -- replacements - -data Files = Files - { f_full :: String - , f_now :: String - , f_voltage :: String - , f_current :: String - } | NoFiles - -data Battery = Battery - { full :: Float - , now :: Float - , voltage :: Float - , current :: Float - } - -batteryFiles :: String -> IO Files -batteryFiles bat = - do is_charge <- fileExist $ prefix ++ "/charge_now" - is_energy <- fileExist $ prefix ++ "/energy_now" - return $ case (is_charge, is_energy) of - (True, _) -> files "/charge" - (_, True) -> files "/energy" - _ -> NoFiles - where prefix = base ++ "/" ++ bat - files ch = Files { f_full = prefix ++ ch ++ "_full" - , f_now = prefix ++ ch ++ "_now" - , f_current = prefix ++ "/current_now" - , f_voltage = prefix ++ "/voltage_now" } - -haveAc :: IO (Maybe Bool) -haveAc = do know <- fileExist $ base ++ "/AC/online" - if know - then do s <- B.unpack `fmap` catRead (base ++ "/AC/online") - return $ Just $ s == "1\n" - else return Nothing - -readBattery :: Files -> IO Battery -readBattery NoFiles = return $ Battery 0 0 0 0 -readBattery files = - do a <- grab $ f_full files -- microwatthours - b <- grab $ f_now files - c <- grab $ f_voltage files -- microvolts - d <- grab $ f_current files -- microwatts (huh!) - return $ Battery (3600 * a / 1000000) -- wattseconds - (3600 * b / 1000000) -- wattseconds - (c / 1000000) -- volts - (d / c) -- amperes - where grab = fmap (read . B.unpack) . catRead - -readBatteries :: BattOpts -> [Files] -> IO Result -readBatteries opts bfs = - do bats <- mapM readBattery (take 3 bfs) - ac' <- haveAc - let ac = (ac' == Just True) - sign = if ac then 1 else -1 - left = sum (map now bats) / sum (map full bats) - watts = sign * sum (map voltage bats) * sum (map current bats) - time = if watts == 0 then 0 else sum $ map time' bats -- negate sign - time' b = (if ac then full b - now b else now b) / (sign * watts) - acstr = case ac' of - Nothing -> "?" - Just True -> onString opts - Just False -> offString opts - return $ if isNaN left then NA else Result left watts time acstr - -runBatt :: [String] -> Monitor String -runBatt = runBatt' ["BAT0","BAT1","BAT2"] - -runBatt' :: [String] -> [String] -> Monitor String -runBatt' bfs args = do - opts <- io $ parseOpts args - c <- io $ readBatteries opts =<< mapM batteryFiles bfs - case c of - Result x w t s -> - do l <- fmtPercent x - parseTemplate (l ++ s:[fmtTime $ floor t, fmtWatts w opts]) - NA -> return "N/A" - where fmtPercent :: Float -> Monitor [String] - fmtPercent x = do - p <- showPercentWithColors x - b <- showPercentBar (100 * x) x - return [b, p] - fmtWatts x o = color x o $ showDigits 1 x ++ "W" - fmtTime :: Integer -> String - fmtTime x = hours ++ ":" ++ if length minutes == 2 - then minutes else '0' : minutes - where hours = show (x `div` 3600) - minutes = show ((x `mod` 3600) `div` 60) - maybeColor Nothing _ = "" - maybeColor (Just c) str = "" ++ str ++ "" - color x o | x >= 0 = maybeColor (posColor o) - | x >= highThreshold o = maybeColor (highWColor o) - | x >= lowThreshold o = maybeColor (mediumWColor o) - | otherwise = maybeColor (lowWColor o) diff --git a/Plugins/Monitors/Common.hs b/Plugins/Monitors/Common.hs deleted file mode 100644 index cc1a6a7..0000000 --- a/Plugins/Monitors/Common.hs +++ /dev/null @@ -1,446 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Common --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- Utilities for creating monitors for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Common ( - -- * Monitors - -- $monitor - Monitor - , MConfig (..) - , Opts (..) - , setConfigValue - , getConfigValue - , mkMConfig - , runM - , io - -- * Parsers - -- $parsers - , runP - , skipRestOfLine - , getNumbers - , getNumbersAsString - , getAllBut - , getAfterString - , skipTillString - , parseTemplate - -- ** String Manipulation - -- $strings - , padString - , showWithPadding - , showWithColors - , showWithColors' - , showPercentWithColors - , showPercentsWithColors - , showPercentBar - , showLogBar - , showWithUnits - , takeDigits - , showDigits - , floatToPercent - , parseFloat - , parseInt - , stringParser - -- * Threaded Actions - -- $thread - , doActionTwiceWithDelay - , catRead - ) where - - -import Control.Concurrent -import Control.Monad.Reader -import qualified Data.ByteString.Lazy.Char8 as B -import Data.IORef -import qualified Data.Map as Map -import Data.List -import Numeric -import Text.ParserCombinators.Parsec -import System.Console.GetOpt -import Control.Exception (SomeException,handle) -import System.Process (readProcess) - -import Plugins --- $monitor - -type Monitor a = ReaderT MConfig IO a - -data MConfig = - MC { normalColor :: IORef (Maybe String) - , low :: IORef Int - , lowColor :: IORef (Maybe String) - , high :: IORef Int - , highColor :: IORef (Maybe String) - , template :: IORef String - , export :: IORef [String] - , ppad :: IORef Int - , minWidth :: IORef Int - , maxWidth :: IORef Int - , padChars :: IORef String - , padRight :: IORef Bool - , barBack :: IORef String - , barFore :: IORef String - , barWidth :: IORef Int - , useSuffix :: IORef Bool - } - --- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' -type Selector a = MConfig -> IORef a - -sel :: Selector a -> Monitor a -sel s = - do hs <- ask - liftIO $ readIORef (s hs) - -mods :: Selector a -> (a -> a) -> Monitor () -mods s m = - do v <- ask - io $ modifyIORef (s v) m - -setConfigValue :: a -> Selector a -> Monitor () -setConfigValue v s = - mods s (\_ -> v) - -getConfigValue :: Selector a -> Monitor a -getConfigValue = sel - -mkMConfig :: String - -> [String] - -> IO MConfig -mkMConfig tmpl exprts = - do lc <- newIORef Nothing - l <- newIORef 33 - nc <- newIORef Nothing - h <- newIORef 66 - hc <- newIORef Nothing - t <- newIORef tmpl - e <- newIORef exprts - p <- newIORef 0 - mn <- newIORef 0 - mx <- newIORef 0 - pc <- newIORef " " - pr <- newIORef False - bb <- newIORef ":" - bf <- newIORef "#" - bw <- newIORef 10 - up <- newIORef False - return $ MC nc l lc h hc t e p mn mx pc pr bb bf bw up - -data Opts = HighColor String - | NormalColor String - | LowColor String - | Low String - | High String - | Template String - | PercentPad String - | MinWidth String - | MaxWidth String - | Width String - | PadChars String - | PadAlign String - | BarBack String - | BarFore String - | BarWidth String - | UseSuffix String - -options :: [OptDescr Opts] -options = - [ Option "H" ["High"] (ReqArg High "number" ) "The high threshold" - , Option "L" ["Low"] (ReqArg Low "number" ) "The low threshold" - , Option "h" ["high"] (ReqArg HighColor "color number" ) "Color for the high threshold: ex \"#FF0000\"" - , Option "n" ["normal"] (ReqArg NormalColor "color number" ) "Color for the normal threshold: ex \"#00FF00\"" - , Option "l" ["low"] (ReqArg LowColor "color number" ) "Color for the low threshold: ex \"#0000FF\"" - , Option "t" ["template"] (ReqArg Template "output template" ) "Output template." - , Option "S" ["suffix"] (ReqArg UseSuffix "True/False" ) "Use % to display percents or other suffixes." - , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width." - , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width" ) "Minimum field width" - , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width" ) "Maximum field width" - , Option "w" ["width"] (ReqArg Width "fixed width" ) "Fixed field width" - , Option "c" ["padchars"] (ReqArg PadChars "padding chars" ) "Characters to use for padding" - , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right" - , Option "b" ["bback"] (ReqArg BarBack "bar background" ) "Characters used to draw bar backgrounds" - , Option "f" ["bfore"] (ReqArg BarFore "bar foreground" ) "Characters used to draw bar foregrounds" - , Option "W" ["bwidth"] (ReqArg BarWidth "bar width" ) "Bar width" - ] - -doArgs :: [String] - -> ([String] -> Monitor String) - -> Monitor String -doArgs args action = - case getOpt Permute options args of - (o, n, []) -> do doConfigOptions o - action n - (_, _, errs) -> return (concat errs) - -doConfigOptions :: [Opts] -> Monitor () -doConfigOptions [] = io $ return () -doConfigOptions (o:oo) = - do let next = doConfigOptions oo - nz s = let x = read s in max 0 x - bool = (`elem` ["True", "true", "Yes", "yes", "On", "on"]) - (case o of - High h -> setConfigValue (read h) high - Low l -> setConfigValue (read l) low - HighColor c -> setConfigValue (Just c) highColor - NormalColor c -> setConfigValue (Just c) normalColor - LowColor c -> setConfigValue (Just c) lowColor - Template t -> setConfigValue t template - PercentPad p -> setConfigValue (nz p) ppad - MinWidth w -> setConfigValue (nz w) minWidth - MaxWidth w -> setConfigValue (nz w) maxWidth - Width w -> setConfigValue (nz w) minWidth >> - setConfigValue (nz w) maxWidth - PadChars s -> setConfigValue s padChars - PadAlign a -> setConfigValue ("r" `isPrefixOf` a) padRight - BarBack s -> setConfigValue s barBack - BarFore s -> setConfigValue s barFore - BarWidth w -> setConfigValue (nz w) barWidth - UseSuffix u -> setConfigValue (bool u) useSuffix) >> next - -runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int - -> (String -> IO ()) -> IO () -runM args conf action r cb = handle (cb . showException) loop - where ac = doArgs args action - loop = conf >>= runReaderT ac >>= cb >> tenthSeconds r >> loop - -showException :: SomeException -> String -showException = ("error: "++) . show . flip asTypeOf undefined - -io :: IO a -> Monitor a -io = liftIO - --- $parsers - -runP :: Parser [a] -> String -> IO [a] -runP p i = - case parse p "" i of - Left _ -> return [] - Right x -> return x - -getAllBut :: String -> Parser String -getAllBut s = - manyTill (noneOf s) (char $ head s) - -getNumbers :: Parser Float -getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n - -getNumbersAsString :: Parser String -getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n - -skipRestOfLine :: Parser Char -skipRestOfLine = - do many $ noneOf "\n\r" - newline - -getAfterString :: String -> Parser String -getAfterString s = - do { try $ manyTill skipRestOfLine $ string s - ; manyTill anyChar newline - } <|> return "" - -skipTillString :: String -> Parser String -skipTillString s = - manyTill skipRestOfLine $ string s - --- | Parses the output template string -templateStringParser :: Parser (String,String,String) -templateStringParser = - do { s <- nonPlaceHolder - ; com <- templateCommandParser - ; ss <- nonPlaceHolder - ; return (s, com, ss) - } - where - nonPlaceHolder = liftM concat . many $ - many1 (noneOf "<") <|> colorSpec - --- | Recognizes color specification and returns it unchanged -colorSpec :: Parser String -colorSpec = try (string "") <|> try ( - do string " char ',' <|> char '#') - char '>' - return $ "") - --- | Parses the command part of the template string -templateCommandParser :: Parser String -templateCommandParser = - do { char '<' - ; com <- many $ noneOf ">" - ; char '>' - ; return com - } - --- | Combines the template parsers -templateParser :: Parser [(String,String,String)] -templateParser = many templateStringParser --"%") - --- | Takes a list of strings that represent the values of the exported --- keys. The strings are joined with the exported keys to form a map --- to be combined with 'combine' to the parsed template. Returns the --- final output of the monitor. -parseTemplate :: [String] -> Monitor String -parseTemplate l = - do t <- getConfigValue template - s <- io $ runP templateParser t - e <- getConfigValue export - let m = Map.fromList . zip e $ l - return $ combine m s - --- | Given a finite "Map" and a parsed templatet produces the --- | resulting output string. -combine :: Map.Map String String -> [(String, String, String)] -> String -combine _ [] = [] -combine m ((s,ts,ss):xs) = - s ++ str ++ ss ++ combine m xs - where str = Map.findWithDefault err ts m - err = "<" ++ ts ++ " not found!>" - --- $strings - -type Pos = (Int, Int) - -takeDigits :: Int -> Float -> Float -takeDigits d n = - fromIntegral (round (n * fact) :: Int) / fact - where fact = 10 ^ d - -showDigits :: (RealFloat a) => Int -> a -> String -showDigits d n = showFFloat (Just d) n "" - -showWithUnits :: Int -> Int -> Float -> String -showWithUnits d n x - | x < 0 = '-' : showWithUnits d n (-x) - | n > 3 || x < 10^(d + 1) = show (round x :: Int) ++ units n - | x <= 1024 = showDigits d (x/1024) ++ units (n+1) - | otherwise = showWithUnits d (n+1) (x/1024) - where units = (!!) ["B", "K", "M", "G", "T"] - -padString :: Int -> Int -> String -> Bool -> String -> String -padString mnw mxw pad pr s = - let len = length s - rmin = if mnw <= 0 then 1 else mnw - rmax = if mxw <= 0 then max len rmin else mxw - (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin) - rlen = min (max rmn len) rmx - in if rlen < len then - take rlen s - else let ps = take (rlen - len) (cycle pad) - in if pr then s ++ ps else ps ++ s - -parseFloat :: String -> Float -parseFloat s = case readFloat s of - (v, _):_ -> v - _ -> 0 - -parseInt :: String -> Int -parseInt s = case readDec s of - (v, _):_ -> v - _ -> 0 - -floatToPercent :: Float -> Monitor String -floatToPercent n = - do pad <- getConfigValue ppad - pc <- getConfigValue padChars - pr <- getConfigValue padRight - up <- getConfigValue useSuffix - let p = showDigits 0 (n * 100) - ps = if up then "%" else "" - return $ padString pad pad pc pr p ++ ps - -stringParser :: Pos -> B.ByteString -> String -stringParser (x,y) = - B.unpack . li x . B.words . li y . B.lines - where li i l | length l > i = l !! i - | otherwise = B.empty - -setColor :: String -> Selector (Maybe String) -> Monitor String -setColor str s = - do a <- getConfigValue s - case a of - Nothing -> return str - Just c -> return $ - "" ++ str ++ "" - -showWithPadding :: String -> Monitor String -showWithPadding s = - do mn <- getConfigValue minWidth - mx <- getConfigValue maxWidth - p <- getConfigValue padChars - pr <- getConfigValue padRight - return $ padString mn mx p pr s - -colorizeString :: (Num a, Ord a) => a -> String -> Monitor String -colorizeString x s = do - h <- getConfigValue high - l <- getConfigValue low - let col = setColor s - [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low - head $ [col highColor | x > hh ] ++ - [col normalColor | x > ll ] ++ - [col lowColor | True] - -showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String -showWithColors f x = showWithPadding (f x) >>= colorizeString x - -showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String -showWithColors' str = showWithColors (const str) - -showPercentsWithColors :: [Float] -> Monitor [String] -showPercentsWithColors fs = - do fstrs <- mapM floatToPercent fs - zipWithM (showWithColors . const) fstrs (map (*100) fs) - -showPercentWithColors :: Float -> Monitor String -showPercentWithColors f = liftM head $ showPercentsWithColors [f] - -showPercentBar :: Float -> Float -> Monitor String -showPercentBar v x = do - bb <- getConfigValue barBack - bf <- getConfigValue barFore - bw <- getConfigValue barWidth - let len = min bw $ round (fromIntegral bw * x) - s <- colorizeString v (take len $ cycle bf) - return $ s ++ take (bw - len) (cycle bb) - -showLogBar :: Float -> Float -> Monitor String -showLogBar f v = do - h <- fromIntegral `fmap` getConfigValue high - l <- fromIntegral `fmap` getConfigValue low - bw <- fromIntegral `fmap` getConfigValue barWidth - let [ll, hh] = sort [l, h] - choose x | x == 0.0 = 0 - | x <= ll = 1 / bw - | otherwise = f + logBase 2 (x / hh) / bw - showPercentBar v $ choose v - --- $threads - -doActionTwiceWithDelay :: Int -> IO [a] -> IO ([a], [a]) -doActionTwiceWithDelay delay action = - do v1 <- newMVar [] - forkIO $! getData action v1 0 - v2 <- newMVar [] - forkIO $! getData action v2 delay - threadDelay (delay `div` 3 * 4) - a <- readMVar v1 - b <- readMVar v2 - return (a,b) - -getData :: IO a -> MVar a -> Int -> IO () -getData action var d = - do threadDelay d - s <- action - modifyMVar_ var (\_ -> return $! s) - -catRead :: FilePath -> IO B.ByteString -catRead file = B.pack `fmap` readProcess "/bin/cat" [file] "" diff --git a/Plugins/Monitors/CoreCommon.hs b/Plugins/Monitors/CoreCommon.hs deleted file mode 100644 index 80e7700..0000000 --- a/Plugins/Monitors/CoreCommon.hs +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CoreCommon --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek --- Stability : unstable --- Portability : unportable --- --- The common part for cpu core monitors (e.g. cpufreq, coretemp) --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CoreCommon where - -import Plugins.Monitors.Common -import System.Posix.Files (fileExist) -import System.IO (withFile, IOMode(ReadMode), hGetLine) -import System.Directory -import Data.Char (isDigit) -import Data.List (isPrefixOf) - --- | --- Function checks the existence of first file specified by pattern and if the --- file doesn't exists failure message is shown, otherwise the data retrieval --- is performed. -checkedDataRetrieval :: (Num a, Ord a, Show a) => - String -> String -> String -> String -> (Double -> a) - -> (a -> String) -> Monitor String -checkedDataRetrieval failureMessage dir file pattern trans fmt = do - exists <- io $ fileExist $ concat [dir, "/", pattern, "0/", file] - case exists of - False -> return failureMessage - True -> retrieveData dir file pattern trans fmt - --- | --- Function retrieves data from files in directory dir specified by --- pattern. String values are converted to double and 'trans' applied --- to each one. Final array is processed by template parser function --- and returned as monitor string. -retrieveData :: (Num a, Ord a, Show a) => - String -> String -> String -> (Double -> a) -> (a -> String) -> - Monitor String -retrieveData dir file pattern trans fmt = do - count <- io $ dirCount dir pattern - contents <- io $ mapM getGuts $ files count - values <- mapM (showWithColors fmt) $ map conversion contents - parseTemplate values - where - getGuts f = withFile f ReadMode hGetLine - dirCount path str = getDirectoryContents path - >>= return . length - . filter (\s -> str `isPrefixOf` s - && isDigit (last s)) - files count = map (\i -> concat [dir, "/", pattern, show i, "/", file]) - [0 .. count - 1] - conversion = trans . (read :: String -> Double) - diff --git a/Plugins/Monitors/CoreTemp.hs b/Plugins/Monitors/CoreTemp.hs deleted file mode 100644 index a24b284..0000000 --- a/Plugins/Monitors/CoreTemp.hs +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CoreTemp --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek --- Stability : unstable --- Portability : unportable --- --- A core temperature monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CoreTemp where - -import Plugins.Monitors.Common -import Plugins.Monitors.CoreCommon - --- | --- Core temperature default configuration. Default template contains only one --- core temperature, user should specify custom template in order to get more --- core frequencies. -coreTempConfig :: IO MConfig -coreTempConfig = mkMConfig - "Temp: C" -- template - (zipWith (++) (repeat "core") (map show [0 :: Int ..])) -- available - -- replacements - --- | --- Function retrieves monitor string holding the core temperature --- (or temperatures) -runCoreTemp :: [String] -> Monitor String -runCoreTemp _ = do - let dir = "/sys/bus/platform/devices" - file = "temp1_input" - pattern = "coretemp." - divisor = 1e3 :: Double - failureMessage = "CoreTemp: N/A" - checkedDataRetrieval failureMessage dir file pattern (/divisor) show - diff --git a/Plugins/Monitors/Cpu.hs b/Plugins/Monitors/Cpu.hs deleted file mode 100644 index ab89246..0000000 --- a/Plugins/Monitors/Cpu.hs +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Cpu --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A cpu monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Cpu where - -import Plugins.Monitors.Common -import qualified Data.ByteString.Lazy.Char8 as B - -cpuConfig :: IO MConfig -cpuConfig = mkMConfig - "Cpu: %" - ["bar","total","user","nice","system","idle"] - -cpuData :: IO [Float] -cpuData = do s <- B.readFile "/proc/stat" - return $ cpuParser s - -cpuParser :: B.ByteString -> [Float] -cpuParser = - map (read . B.unpack) . tail . B.words . head . B.lines - -parseCPU :: IO [Float] -parseCPU = - do (a,b) <- doActionTwiceWithDelay 750000 cpuData - let dif = zipWith (-) b a - tot = foldr (+) 0 dif - percent = map (/ tot) dif - return percent - -formatCpu :: [Float] -> Monitor [String] -formatCpu [] = return $ repeat "" -formatCpu xs = do - let t = foldr (+) 0 $ take 3 xs - b <- showPercentBar (100 * t) t - ps <- showPercentsWithColors (t:xs) - return (b:ps) - -runCpu :: [String] -> Monitor String -runCpu _ = - do c <- io parseCPU - l <- formatCpu c - parseTemplate l diff --git a/Plugins/Monitors/CpuFreq.hs b/Plugins/Monitors/CpuFreq.hs deleted file mode 100644 index 4f01922..0000000 --- a/Plugins/Monitors/CpuFreq.hs +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CpuFreq --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek --- Stability : unstable --- Portability : unportable --- --- A cpu frequency monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CpuFreq where - -import Plugins.Monitors.Common -import Plugins.Monitors.CoreCommon - --- | --- Cpu frequency default configuration. Default template contains only one --- core frequency, user should specify custom template in order to get more --- cpu frequencies. -cpuFreqConfig :: IO MConfig -cpuFreqConfig = mkMConfig - "Freq: " -- template - (zipWith (++) (repeat "cpu") (map show [0 :: Int ..])) -- available - -- replacements - --- | --- Function retrieves monitor string holding the cpu frequency (or --- frequencies) -runCpuFreq :: [String] -> Monitor String -runCpuFreq _ = do - let dir = "/sys/devices/system/cpu" - file = "cpufreq/scaling_cur_freq" - pattern = "cpu" - divisor = 1e6 :: Double - failureMessage = "CpuFreq: N/A" - fmt x | x < 1 = show (round (x * 1000) :: Integer) ++ "MHz" - | otherwise = showDigits 1 x ++ "GHz" - checkedDataRetrieval failureMessage dir file pattern (/divisor) fmt - diff --git a/Plugins/Monitors/Disk.hs b/Plugins/Monitors/Disk.hs deleted file mode 100644 index f3a7a2a..0000000 --- a/Plugins/Monitors/Disk.hs +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Disk --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- Disk usage and throughput monitors for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Disk ( diskUConfig, runDiskU - , diskIOConfig, runDiskIO - ) where - -import Plugins.Monitors.Common -import StatFS - -import Control.Monad (zipWithM) -import qualified Data.ByteString.Lazy.Char8 as B -import Data.List (isPrefixOf, find, intercalate) - -diskIOConfig :: IO MConfig -diskIOConfig = mkMConfig "" ["total", "read", "write", - "totalbar", "readbar", "writebar"] - -diskUConfig :: IO MConfig -diskUConfig = mkMConfig "" - ["size", "free", "used", "freep", "usedp", "freebar", "usedbar"] - -type DevName = String -type Path = String - -mountedDevices :: [String] -> IO [(DevName, Path)] -mountedDevices req = do - s <- B.readFile "/etc/mtab" - return (parse s) - where - parse = map undev . filter isDev . map (firstTwo . B.words) . B.lines - firstTwo (a:b:_) = (B.unpack a, B.unpack b) - firstTwo _ = ("", "") - isDev (d, p) = "/dev/" `isPrefixOf` d && - (p `elem` req || drop 5 d `elem` req) - undev (d, f) = (drop 5 d, f) - -diskData :: IO [(DevName, [Float])] -diskData = do - s <- B.readFile "/proc/diskstats" - let extract ws = (head ws, map read (tail ws)) - return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s) - -mountedData :: [DevName] -> IO [(DevName, [Float])] -mountedData devs = do - (dt, dt') <- doActionTwiceWithDelay 750000 diskData - return $ map (parseDev (zipWith diff dt' dt)) devs - where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys) - -parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float]) -parseDev dat dev = - case find ((==dev) . fst) dat of - Nothing -> (dev, [0, 0, 0]) - Just (_, xs) -> - let rSp = speed (xs !! 2) (xs !! 3) - wSp = speed (xs !! 6) (xs !! 7) - sp = speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7) - speed x t = if t == 0 then 0 else 500 * x / t - dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0] - in (dev, dat') - -fsStats :: String -> IO [Integer] -fsStats path = do - stats <- getFileSystemStats path - case stats of - Nothing -> return [-1, -1, -1] - Just f -> let tot = fsStatByteCount f - free = fsStatBytesAvailable f - used = fsStatBytesUsed f - in return [tot, free, used] - -speedToStr :: Float -> String -speedToStr = showWithUnits 2 1 - -sizeToStr :: Integer -> String -sizeToStr = showWithUnits 3 0 . fromIntegral - -findTempl :: DevName -> Path -> [(String, String)] -> String -findTempl dev path disks = - case find devOrPath disks of - Just (_, t) -> t - Nothing -> "" - where devOrPath (d, _) = d == dev || d == path - -devTemplates :: [(String, String)] - -> [(DevName, Path)] - -> [(DevName, [Float])] - -> [(String, [Float])] -devTemplates disks mounted dat = - map (\(d, p) -> (findTempl d p disks, findData d)) mounted - where findData dev = case find ((==dev) . fst) dat of - Nothing -> [0, 0, 0] - Just (_, xs) -> xs - -runDiskIO' :: (String, [Float]) -> Monitor String -runDiskIO' (tmp, xs) = do - s <- mapM (showWithColors speedToStr) xs - b <- mapM (showLogBar 0.8) xs - setConfigValue tmp template - parseTemplate $ s ++ b - -runDiskIO :: [(String, String)] -> [String] -> Monitor String -runDiskIO disks _ = do - mounted <- io $ mountedDevices (map fst disks) - dat <- io $ mountedData (map fst mounted) - strs <- mapM runDiskIO' $ devTemplates disks mounted dat - return $ intercalate " " strs - -runDiskU' :: String -> String -> Monitor String -runDiskU' tmp path = do - setConfigValue tmp template - fstats <- io $ fsStats path - let strs = map sizeToStr fstats - freep = (fstats !! 1) * 100 `div` head fstats - fr = fromIntegral freep / 100 - s <- zipWithM showWithColors' strs [100, freep, 100 - freep] - sp <- showPercentsWithColors [fr, 1 - fr] - fb <- showPercentBar (fromIntegral freep) fr - ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr) - parseTemplate $ s ++ sp ++ [fb, ub] - -runDiskU :: [(String, String)] -> [String] -> Monitor String -runDiskU disks _ = do - devs <- io $ mountedDevices (map fst disks) - strs <- mapM (\(d, p) -> runDiskU' (findTempl d p disks) p) devs - return $ intercalate " " strs diff --git a/Plugins/Monitors/MPD.hs b/Plugins/Monitors/MPD.hs deleted file mode 100644 index daf0ed4..0000000 --- a/Plugins/Monitors/MPD.hs +++ /dev/null @@ -1,115 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.MPD --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- MPD status and song --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.MPD ( mpdConfig, runMPD ) where - -import Plugins.Monitors.Common -import System.Console.GetOpt -import qualified Network.MPD as M - -mpdConfig :: IO MConfig -mpdConfig = mkMConfig "MPD: " - [ "bar", "state", "statei", "volume", "length" - , "lapsed", "remaining", "plength", "ppos", "file" - , "name", "artist", "composer", "performer" - , "album", "title", "track", "genre" - ] - -data MOpts = MOpts - { mPlaying :: String - , mStopped :: String - , mPaused :: String - , mHost :: String - , mPort :: Integer - , mPassword :: String - } - -defaultOpts :: MOpts -defaultOpts = MOpts - { mPlaying = ">>" - , mStopped = "><" - , mPaused = "||" - , mHost = "127.0.0.1" - , mPort = 6600 - , mPassword = "" - } - -options :: [OptDescr (MOpts -> MOpts)] -options = - [ Option "P" ["playing"] (ReqArg (\x o -> o { mPlaying = x }) "") "" - , Option "S" ["stopped"] (ReqArg (\x o -> o { mStopped = x }) "") "" - , Option "Z" ["paused"] (ReqArg (\x o -> o { mPaused = x }) "") "" - , Option "h" ["host"] (ReqArg (\x o -> o { mHost = x }) "") "" - , Option "p" ["port"] (ReqArg (\x o -> o { mPort = read x }) "") "" - , Option "x" ["password"] (ReqArg (\x o -> o { mPassword = x }) "") "" - ] - -runMPD :: [String] -> Monitor String -runMPD args = do - opts <- io $ mopts args - let mpd = M.withMPDEx (mHost opts) (mPort opts) (mPassword opts) - status <- io $ mpd M.status - song <- io $ mpd M.currentSong - s <- parseMPD status song opts - parseTemplate s - -mopts :: [String] -> IO MOpts -mopts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs - -parseMPD :: M.Response M.Status -> M.Response (Maybe M.Song) -> MOpts - -> Monitor [String] -parseMPD (Left e) _ _ = return $ show e:repeat "" -parseMPD (Right st) song opts = do - songData <- parseSong song - bar <- showPercentBar (100 * b) b - return $ [bar, ss, si, vol, len, lap, remain, plen, ppos] ++ songData - where s = M.stState st - ss = show s - si = stateGlyph s opts - vol = int2str $ M.stVolume st - (p, t) = M.stTime st - [lap, len, remain] = map showTime [floor p, t, max 0 (t - floor p)] - b = if t > 0 then realToFrac $ p / fromIntegral t else 0 - plen = int2str $ M.stPlaylistLength st - ppos = maybe "" (int2str . (+1)) $ M.stSongPos st - -stateGlyph :: M.State -> MOpts -> String -stateGlyph s o = - case s of - M.Playing -> mPlaying o - M.Paused -> mPaused o - M.Stopped -> mStopped o - -parseSong :: M.Response (Maybe M.Song) -> Monitor [String] -parseSong (Left _) = return $ repeat "" -parseSong (Right Nothing) = return $ repeat "" -parseSong (Right (Just s)) = - let join [] = "" - join (x:xs) = foldl (\a o -> a ++ ", " ++ o) x xs - str sel = maybe "" join (M.sgGet sel s) - sels = [ M.Name, M.Artist, M.Composer, M.Performer - , M.Album, M.Title, M.Track, M.Genre ] - fields = M.sgFilePath s : map str sels - in mapM showWithPadding fields - -showTime :: Integer -> String -showTime t = int2str minutes ++ ":" ++ int2str seconds - where minutes = t `div` 60 - seconds = t `mod` 60 - -int2str :: (Num a, Ord a) => a -> String -int2str x = if x < 10 then '0':sx else sx where sx = show x diff --git a/Plugins/Monitors/Mem.hs b/Plugins/Monitors/Mem.hs deleted file mode 100644 index 5c55ee2..0000000 --- a/Plugins/Monitors/Mem.hs +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Mem --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A memory monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where - -import Plugins.Monitors.Common - -memConfig :: IO MConfig -memConfig = mkMConfig - "Mem: % (M)" -- template - ["usedbar", "freebar", "usedratio", "total", - "free", "buffer", "cache", "rest", "used"] -- available replacements - -fileMEM :: IO String -fileMEM = readFile "/proc/meminfo" - -parseMEM :: IO [Float] -parseMEM = - do file <- fileMEM - let content = map words $ take 4 $ lines file - [total, free, buffer, cache] = map (\line -> (read $ line !! 1 :: Float) / 1024) content - rest = free + buffer + cache - used = total - rest - usedratio = used / total - return [usedratio, total, free, buffer, cache, rest, used] - -totalMem :: IO Float -totalMem = fmap ((*1024) . (!!1)) parseMEM - -usedMem :: IO Float -usedMem = fmap ((*1024) . (!!6)) parseMEM - -formatMem :: [Float] -> Monitor [String] -formatMem (r:xs) = - do let f = showDigits 0 - rr = 100 * r - ub <- showPercentBar rr r - fb <- showPercentBar (100 - rr) (1 - r) - rs <- showPercentWithColors r - s <- mapM (showWithColors f) xs - return (ub:fb:rs:s) -formatMem _ = return $ replicate 9 "N/A" - -runMem :: [String] -> Monitor String -runMem _ = - do m <- io parseMEM - l <- formatMem m - parseTemplate l diff --git a/Plugins/Monitors/MultiCpu.hs b/Plugins/Monitors/MultiCpu.hs deleted file mode 100644 index 535196a..0000000 --- a/Plugins/Monitors/MultiCpu.hs +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.MultiCpu --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega --- Stability : unstable --- Portability : unportable --- --- A multi-cpu monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.MultiCpu(multiCpuConfig, runMultiCpu) where - -import Plugins.Monitors.Common -import qualified Data.ByteString.Lazy.Char8 as B -import Data.List (isPrefixOf, transpose, unfoldr) - -multiCpuConfig :: IO MConfig -multiCpuConfig = - mkMConfig "Cpu: %" $ - map ("auto" ++) monitors - ++ [ k ++ n | n <- "" : map show [0 :: Int ..] - , k <- monitors] - where monitors = ["bar","total","user","nice","system","idle"] - - -cpuData :: IO [[Float]] -cpuData = do s <- B.readFile "/proc/stat" - return $ cpuParser s - -cpuParser :: B.ByteString -> [[Float]] -cpuParser = map parseList . cpuLists - where cpuLists = takeWhile isCpu . map B.words . B.lines - isCpu (w:_) = "cpu" `isPrefixOf` B.unpack w - isCpu _ = False - parseList = map (read . B.unpack) . tail - -parseCpuData :: IO [[Float]] -parseCpuData = - do (as, bs) <- doActionTwiceWithDelay 950000 cpuData - let p0 = zipWith percent bs as - return p0 - -percent :: [Float] -> [Float] -> [Float] -percent b a = if tot > 0 then map (/ tot) $ take 4 dif else [0, 0, 0, 0] - where dif = zipWith (-) b a - tot = foldr (+) 0 dif - -formatMultiCpus :: [[Float]] -> Monitor [String] -formatMultiCpus [] = return $ repeat "" -formatMultiCpus xs = fmap concat $ mapM formatCpu xs - -formatCpu :: [Float] -> Monitor [String] -formatCpu xs - | length xs < 4 = showPercentsWithColors $ replicate 6 0.0 - | otherwise = let t = foldr (+) 0 $ take 3 xs - in do b <- showPercentBar (100 * t) t - ps <- showPercentsWithColors (t:xs) - return (b:ps) - -splitEvery :: (Eq a) => Int -> [a] -> [[a]] -splitEvery n = unfoldr (\x -> if x == [] - then Nothing - else Just $ splitAt n x) - -groupData :: [String] -> [[String]] -groupData = transpose . tail . splitEvery 6 - -formatAutoCpus :: [String] -> Monitor [String] -formatAutoCpus [] = return $ replicate 6 "" -formatAutoCpus xs = return $ map unwords (groupData xs) - -runMultiCpu :: [String] -> Monitor String -runMultiCpu _ = - do c <- io parseCpuData - l <- formatMultiCpus c - a <- formatAutoCpus l - parseTemplate (a ++ l) diff --git a/Plugins/Monitors/Net.hs b/Plugins/Monitors/Net.hs deleted file mode 100644 index d9cd534..0000000 --- a/Plugins/Monitors/Net.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Net --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A net device monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Net (netConfig, runNet) where - -import Plugins.Monitors.Common -import qualified Data.ByteString.Lazy.Char8 as B - -data NetDev = NA - | ND { netDev :: String - , netRx :: Float - , netTx :: Float - } deriving (Eq,Show,Read) - -interval :: Int -interval = 500000 - -netConfig :: IO MConfig -netConfig = mkMConfig - ": KB|KB" -- template - ["dev", "rx", "tx", "rxbar", "txbar"] -- available replacements - --- Given a list of indexes, take the indexed elements from a list. -getNElements :: [Int] -> [a] -> [a] -getNElements ns as = map (as!!) ns - --- Split into words, with word boundaries indicated by the given predicate. --- Drops delimiters. Duplicates 'Data.List.Split.wordsBy'. --- --- > map (wordsBy (`elem` " :")) ["lo:31174097 31174097", "eth0: 43598 88888"] --- --- will become @[["lo","31174097","31174097"], ["eth0","43598","88888"]]@ -wordsBy :: (a -> Bool) -> [a] -> [[a]] -wordsBy f s = case dropWhile f s of - [] -> [] - s' -> w : wordsBy f s'' where (w, s'') = break f s' - -readNetDev :: [String] -> NetDev -readNetDev [] = NA -readNetDev xs = - ND (xs !! 0) (r (xs !! 1)) (r (xs !! 2)) - where r s | s == "" = 0 - | otherwise = read s / 1024 - -fileNET :: IO [NetDev] -fileNET = - do f <- B.readFile "/proc/net/dev" - return $ netParser f - -netParser :: B.ByteString -> [NetDev] -netParser = - map (readNetDev . getNElements [0,1,9] . wordsBy (`elem` " :") . B.unpack) . drop 2 . B.lines - -formatNet :: Float -> Monitor (String, String) -formatNet d = do - s <- getConfigValue useSuffix - let str = if s then (++"Kb/s") . showDigits 1 else showDigits 1 - b <- showLogBar 0.9 d - x <- showWithColors str d - return (x, b) - -printNet :: NetDev -> Monitor String -printNet nd = - case nd of - ND d r t -> do (rx, rb) <- formatNet r - (tx, tb) <- formatNet t - parseTemplate [d,rx,tx,rb,tb] - NA -> return "N/A" - -parseNET :: String -> IO [NetDev] -parseNET nd = - do (a,b) <- doActionTwiceWithDelay interval fileNET - let netRate f da db = takeDigits 2 $ (f db - f da) * fromIntegral (1000000 `div` interval) - diffRate (da,db) = ND (netDev da) - (netRate netRx da db) - (netRate netTx da db) - return $ filter (\d -> netDev d == nd) $ map diffRate $ zip a b - -runNet :: [String] -> Monitor String -runNet nd = - do pn <- io $ parseNET $ head nd - n <- case pn of - [x] -> return x - _ -> return NA - printNet n diff --git a/Plugins/Monitors/Swap.hs b/Plugins/Monitors/Swap.hs deleted file mode 100644 index e466dbb..0000000 --- a/Plugins/Monitors/Swap.hs +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Swap --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A swap usage monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Swap where - -import Plugins.Monitors.Common - -import qualified Data.ByteString.Lazy.Char8 as B - -swapConfig :: IO MConfig -swapConfig = mkMConfig - "Swap: %" -- template - ["usedratio", "total", "used", "free"] -- available replacements - -fileMEM :: IO B.ByteString -fileMEM = B.readFile "/proc/meminfo" - -parseMEM :: IO [Float] -parseMEM = - do file <- fileMEM - let li i l - | l /= [] = head l !! i - | otherwise = B.empty - fs s l - | l == [] = False - | otherwise = head l == B.pack s - get_data s = flip (/) 1024 . read . B.unpack . li 1 . filter (fs s) - st = map B.words . B.lines $ file - tot = get_data "SwapTotal:" st - free = get_data "SwapFree:" st - return [(tot - free) / tot, tot, tot - free, free] - -formatSwap :: [Float] -> Monitor [String] -formatSwap (r:xs) = - do other <- mapM (showWithColors (showDigits 2)) xs - ratio <- showPercentWithColors r - return $ ratio:other -formatSwap _ = return $ replicate 4 "N/A" - -runSwap :: [String] -> Monitor String -runSwap _ = - do m <- io parseMEM - l <- formatSwap m - parseTemplate l diff --git a/Plugins/Monitors/Thermal.hs b/Plugins/Monitors/Thermal.hs deleted file mode 100644 index a3ffe6d..0000000 --- a/Plugins/Monitors/Thermal.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Thermal --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek --- Stability : unstable --- Portability : unportable --- --- A thermal monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Thermal where - -import qualified Data.ByteString.Lazy.Char8 as B -import Plugins.Monitors.Common -import System.Posix.Files (fileExist) - --- | Default thermal configuration. -thermalConfig :: IO MConfig -thermalConfig = mkMConfig - "Thm: C" -- template - ["temp"] -- available replacements - --- | Retrieves thermal information. Argument is name of thermal directory in --- \/proc\/acpi\/thermal_zone. Returns the monitor string parsed according to --- template (either default or user specified). -runThermal :: [String] -> Monitor String -runThermal args = do - let zone = head args - file = "/proc/acpi/thermal_zone/" ++ zone ++ "/temperature" - exists <- io $ fileExist file - case exists of - False -> return $ "Thermal (" ++ zone ++ "): N/A" - True -> do number <- io $ B.readFile file - >>= return . (read :: String -> Int) - . stringParser (1, 0) - thermal <- showWithColors show number - parseTemplate [ thermal ] - diff --git a/Plugins/Monitors/Top.hs b/Plugins/Monitors/Top.hs deleted file mode 100644 index e45210c..0000000 --- a/Plugins/Monitors/Top.hs +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Top --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- Process activity and memory consumption monitors --- ------------------------------------------------------------------------------ - -{-# LANGUAGE ForeignFunctionInterface #-} - -module Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where - -import Plugins.Monitors.Common - -import Control.Exception (SomeException, handle) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (sortBy, foldl') -import Data.Ord (comparing) -import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) -import System.Directory (getDirectoryContents) -import System.FilePath (()) -import System.IO (IOMode(ReadMode), hGetLine, withFile) -import System.Posix.Unistd (SysVar(ClockTick), getSysVar) - -import Foreign.C.Types - -maxEntries :: Int -maxEntries = 10 - -intStrs :: [String] -intStrs = map show [1..maxEntries] - -topMemConfig :: IO MConfig -topMemConfig = mkMConfig "" - [ k ++ n | n <- intStrs , k <- ["name", "mem", "both"]] - -topConfig :: IO MConfig -topConfig = mkMConfig "" - ("no" : [ k ++ n | n <- intStrs - , k <- [ "name", "cpu", "both" - , "mname", "mem", "mboth"]]) - -foreign import ccall "unistd.h getpagesize" - c_getpagesize :: CInt - -pageSize :: Float -pageSize = fromIntegral c_getpagesize / 1024 - -processes :: IO [FilePath] -processes = fmap (filter isPid) (getDirectoryContents "/proc") - where isPid = (`elem` ['0'..'9']) . head - -getProcessData :: FilePath -> IO [String] -getProcessData pidf = - handle ign $ withFile ("/proc" pidf "stat") ReadMode readWords - where readWords = fmap words . hGetLine - ign = const (return []) :: SomeException -> IO [String] - -handleProcesses :: ([String] -> a) -> IO [a] -handleProcesses f = - fmap (foldl' (\a p -> if length p < 15 then a else f p : a) []) - (processes >>= mapM getProcessData) - -showInfo :: String -> String -> Float -> Monitor [String] -showInfo nm sms mms = do - mnw <- getConfigValue maxWidth - mxw <- getConfigValue minWidth - let lsms = length sms - nmw = mnw - lsms - 1 - nmx = mxw - lsms - 1 - rnm = if nmw > 0 then padString nmw nmx " " True nm else nm - mstr <- showWithColors' sms mms - both <- showWithColors' (rnm ++ " " ++ sms) mms - return [nm, mstr, both] - -processName :: [String] -> String -processName = drop 1 . init . (!!1) - -sortTop :: [(String, Float)] -> [(String, Float)] -sortTop = sortBy (flip (comparing snd)) - -type MemInfo = (String, Float) - -meminfo :: [String] -> MemInfo -meminfo fs = (processName fs, pageSize * parseFloat (fs!!23)) - -meminfos :: IO [MemInfo] -meminfos = handleProcesses meminfo - -showMemInfo :: Float -> MemInfo -> Monitor [String] -showMemInfo scale (nm, rss) = - showInfo nm (showWithUnits 2 1 rss) (100 * rss / sc) - where sc = if scale > 0 then scale else 100 - -showMemInfos :: [MemInfo] -> Monitor [[String]] -showMemInfos ms = mapM (showMemInfo tm) ms - where tm = sum (map snd ms) - -runTopMem :: [String] -> Monitor String -runTopMem _ = do - mis <- io meminfos - pstr <- showMemInfos (sortTop mis) - parseTemplate $ concat pstr - -type Pid = Int -type TimeInfo = (String, Float) -type TimeEntry = (Pid, TimeInfo) -type Times = [TimeEntry] -type TimesRef = IORef (Times, UTCTime) - -timeMemEntry :: [String] -> (TimeEntry, MemInfo) -timeMemEntry fs = ((p, (n, t)), (n, r)) - where p = parseInt (head fs) - n = processName fs - t = parseFloat (fs!!13) + parseFloat (fs!!14) - (_, r) = meminfo fs - -timeMemEntries :: IO [(TimeEntry, MemInfo)] -timeMemEntries = handleProcesses timeMemEntry - -timeMemInfos :: IO (Times, [MemInfo], Int) -timeMemInfos = fmap res timeMemEntries - where res x = (sortBy (comparing fst) $ map fst x, map snd x, length x) - -combine :: Times -> Times -> Times -combine _ [] = [] -combine [] ts = ts -combine l@((p0, (n0, t0)):ls) r@((p1, (n1, t1)):rs) - | p0 == p1 && n0 == n1 = (p0, (n0, t1 - t0)) : combine ls rs - | p0 <= p1 = combine ls r - | otherwise = (p1, (n1, t1)) : combine l rs - -take' :: Int -> [a] -> [a] -take' m l = let !r = tk m l in length l `seq` r - where tk 0 _ = [] - tk _ [] = [] - tk n (x:xs) = let !r = tk (n - 1) xs in x : r - -topProcesses :: TimesRef -> Float -> IO (Int, [TimeInfo], [MemInfo]) -topProcesses tref scale = do - (t0, c0) <- readIORef tref - (t1, mis, len) <- timeMemInfos - c1 <- getCurrentTime - let scx = realToFrac (diffUTCTime c1 c0) * scale - !scx' = if scx > 0 then scx else scale - nts = map (\(_, (nm, t)) -> (nm, min 100 (t / scx'))) (combine t0 t1) - !t1' = take' (length t1) t1 - !nts' = take' maxEntries (sortTop nts) - !mis' = take' maxEntries (sortTop mis) - writeIORef tref (t1', c1) - return (len, nts', mis') - -showTimeInfo :: TimeInfo -> Monitor [String] -showTimeInfo (n, t) = showInfo n (showDigits 0 t) t - -showTimeInfos :: [TimeInfo] -> Monitor [[String]] -showTimeInfos = mapM showTimeInfo - -runTop :: TimesRef -> Float -> [String] -> Monitor String -runTop tref scale _ = do - (no, ps, ms) <- io $ topProcesses tref scale - pstr <- showTimeInfos ps - mstr <- showMemInfos ms - parseTemplate $ show no : concat (zipWith (++) pstr mstr) ++ repeat "N/A" - -startTop :: [String] -> Int -> (String -> IO ()) -> IO () -startTop a r cb = do - cr <- getSysVar ClockTick - c <- getCurrentTime - tref <- newIORef ([], c) - let scale = fromIntegral cr / 100 - _ <- topProcesses tref scale - runM a topConfig (runTop tref scale) r cb diff --git a/Plugins/Monitors/Uptime.hs b/Plugins/Monitors/Uptime.hs deleted file mode 100644 index 8524bcc..0000000 --- a/Plugins/Monitors/Uptime.hs +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module : Plugins.Monitors.Uptime --- Copyright : (c) 2010 Jose Antonio Ortega Ruiz --- License : BSD3-style (see LICENSE) --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- Created: Sun Dec 12, 2010 20:26 --- --- --- Uptime --- ------------------------------------------------------------------------------- - - -module Plugins.Monitors.Uptime (uptimeConfig, runUptime) where - -import Plugins.Monitors.Common - -import qualified Data.ByteString.Lazy.Char8 as B - -uptimeConfig :: IO MConfig -uptimeConfig = mkMConfig "Up d h m" - ["days", "hours", "minutes", "seconds"] - -readUptime :: IO Float -readUptime = - fmap (read . B.unpack . head . B.words) (B.readFile "/proc/uptime") - -secsPerDay :: Integer -secsPerDay = 24 * 3600 - -uptime :: Monitor [String] -uptime = do - t <- io readUptime - u <- getConfigValue useSuffix - let tsecs = floor t - secs = tsecs `mod` secsPerDay - days = tsecs `quot` secsPerDay - hours = secs `quot` 3600 - mins = (secs `mod` 3600) `div` 60 - ss = secs `mod` 60 - str x s = if u then show x ++ s else show x - mapM (`showWithColors'` days) - [str days "d", str hours "h", str mins "m", str ss "s"] - -runUptime :: [String] -> Monitor String -runUptime _ = uptime >>= parseTemplate diff --git a/Plugins/Monitors/Weather.hs b/Plugins/Monitors/Weather.hs deleted file mode 100644 index 1277438..0000000 --- a/Plugins/Monitors/Weather.hs +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Weather --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A weather monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Weather where - -import Plugins.Monitors.Common - -import Control.Monad (when) -import System.Process -import System.Exit -import System.IO - -import Text.ParserCombinators.Parsec - - -weatherConfig :: IO MConfig -weatherConfig = mkMConfig - ": C, rh % ()" -- template - ["station" -- available replacements - , "stationState" - , "year" - , "month" - , "day" - , "hour" - , "wind" - , "visibility" - , "skyCondition" - , "tempC" - , "tempF" - , "dewPoint" - , "rh" - , "pressure" - ] - -data WeatherInfo = - WI { stationPlace :: String - , stationState :: String - , year :: String - , month :: String - , day :: String - , hour :: String - , wind :: String - , visibility :: String - , skyCondition :: String - , tempC :: Int - , tempF :: Int - , dewPoint :: String - , humidity :: Int - , pressure :: Int - } deriving (Show) - -pTime :: Parser (String, String, String, String) -pTime = do y <- getNumbersAsString - char '.' - m <- getNumbersAsString - char '.' - d <- getNumbersAsString - char ' ' - (h:hh:mi:mimi) <- getNumbersAsString - char ' ' - return (y, m, d ,([h]++[hh]++":"++[mi]++mimi)) - -pTemp :: Parser (Int, Int) -pTemp = do let num = digit <|> char '-' <|> char '.' - f <- manyTill num $ char ' ' - manyTill anyChar $ char '(' - c <- manyTill num $ char ' ' - skipRestOfLine - return $ (floor (read c :: Double), floor (read f :: Double)) - -pRh :: Parser Int -pRh = do s <- manyTill digit $ (char '%' <|> char '.') - return $ read s - -pPressure :: Parser Int -pPressure = do manyTill anyChar $ char '(' - s <- manyTill digit $ char ' ' - skipRestOfLine - return $ read s - -parseData :: Parser [WeatherInfo] -parseData = - do st <- getAllBut "," - space - ss <- getAllBut "(" - skipRestOfLine >> getAllBut "/" - (y,m,d,h) <- pTime - w <- getAfterString "Wind: " - v <- getAfterString "Visibility: " - sk <- getAfterString "Sky conditions: " - skipTillString "Temperature: " - (tC,tF) <- pTemp - dp <- getAfterString "Dew Point: " - skipTillString "Relative Humidity: " - rh <- pRh - skipTillString "Pressure (altimeter): " - p <- pPressure - manyTill skipRestOfLine eof - return $ [WI st ss y m d h w v sk tC tF dp rh p] - -defUrl :: String -defUrl = "http://weather.noaa.gov/pub/data/observations/metar/decoded/" - -getData :: String -> IO String -getData url= - do (i,o,e,p) <- runInteractiveCommand ("curl " ++ defUrl ++ url ++ ".TXT") - exit <- waitForProcess p - let closeHandles = do hClose o - hClose i - hClose e - case exit of - ExitSuccess -> do str <- hGetContents o - when (str == str) $ return () - closeHandles - return str - _ -> do closeHandles - return "Could not retrieve data" - -formatWeather :: [WeatherInfo] -> Monitor String -formatWeather [(WI st ss y m d h w v sk tC tF dp r p)] = - do cel <- showWithColors show tC - far <- showWithColors show tF - parseTemplate [st, ss, y, m, d, h, w, v, sk, cel, far, dp, show r , show p ] -formatWeather _ = return "N/A" - -runWeather :: [String] -> Monitor String -runWeather str = - do d <- io $ getData $ head str - i <- io $ runP parseData d - formatWeather i diff --git a/Plugins/Monitors/Wireless.hs b/Plugins/Monitors/Wireless.hs deleted file mode 100644 index 4ac0c10..0000000 --- a/Plugins/Monitors/Wireless.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Wireless --- Copyright : (c) Jose Antonio Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose Antonio Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A monitor reporting ESSID and link quality for wireless interfaces --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Wireless (wirelessConfig, runWireless) where - -import Plugins.Monitors.Common -import IWlib - -wirelessConfig :: IO MConfig -wirelessConfig = - mkMConfig " " ["essid", "quality", "qualitybar"] - -runWireless :: [String] -> Monitor String -runWireless (iface:_) = do - wi <- io $ getWirelessInfo iface - let essid = wiEssid wi - qlty = wiQuality wi - fqlty = fromIntegral qlty - e = if essid == "" then "N/A" else essid - q <- if qlty >= 0 then showWithColors show qlty else showWithPadding "" - qb <- showPercentBar fqlty (fqlty / 100) - parseTemplate [e, q, qb] -runWireless _ = return "" \ No newline at end of file diff --git a/Plugins/PipeReader.hs b/Plugins/PipeReader.hs deleted file mode 100644 index 3fd0dd4..0000000 --- a/Plugins/PipeReader.hs +++ /dev/null @@ -1,28 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.PipeReader --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from named pipes --- ------------------------------------------------------------------------------ - -module Plugins.PipeReader where - -import System.IO -import Plugins - -data PipeReader = PipeReader String String - deriving (Read, Show) - -instance Exec PipeReader where - alias (PipeReader _ a) = a - start (PipeReader p _) cb = do - h <- openFile p ReadWriteMode - forever (hGetLineSafe h >>= cb) - where forever a = a >> forever a diff --git a/Plugins/StdinReader.hs b/Plugins/StdinReader.hs deleted file mode 100644 index 2ee217e..0000000 --- a/Plugins/StdinReader.hs +++ /dev/null @@ -1,33 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.StdinReader --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from stdin --- ------------------------------------------------------------------------------ - -module Plugins.StdinReader where - -import Prelude hiding (catch) -import System.Posix.Process -import System.Exit -import System.IO -import Control.Exception (SomeException(..),catch) -import Plugins - -data StdinReader = StdinReader - deriving (Read, Show) - -instance Exec StdinReader where - start StdinReader cb = do - cb =<< catch (hGetLineSafe stdin) (\(SomeException e) -> do hPrint stderr e; return "") - eof <- hIsEOF stdin - if eof - then exitImmediately ExitSuccess - else start StdinReader cb diff --git a/Plugins/Utils.hs b/Plugins/Utils.hs deleted file mode 100644 index 1dbcd40..0000000 --- a/Plugins/Utils.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Plugins.Utils --- Copyright: (c) 2010 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: Jose A Ortega Ruiz --- Stability: unstable --- Portability: unportable --- Created: Sat Dec 11, 2010 20:55 --- --- --- Miscellaneous utility functions --- ------------------------------------------------------------------------------- - - -module Plugins.Utils (expandHome, changeLoop) where - -import Control.Monad -import Control.Concurrent.STM - -import System.Environment -import System.FilePath - - -expandHome :: FilePath -> IO FilePath -expandHome ('~':'/':path) = fmap ( path) (getEnv "HOME") -expandHome p = return p - -changeLoop :: Eq a => STM a -> (a -> IO ()) -> IO () -changeLoop s f = atomically s >>= go - where - go old = do - f old - go =<< atomically (do - new <- s - guard (new /= old) - return new) diff --git a/Plugins/XMonadLog.hs b/Plugins/XMonadLog.hs deleted file mode 100644 index 3461e26..0000000 --- a/Plugins/XMonadLog.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Plugins.StdinReader --- Copyright : (c) Spencer Janssen --- License : BSD-style (see LICENSE) --- --- Maintainer : Spencer Janssen --- Stability : unstable --- Portability : unportable --- --- A plugin to display information from _XMONAD_LOG, specified at --- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs --- ------------------------------------------------------------------------------ - -module Plugins.XMonadLog (XMonadLog(..)) where - -import Control.Monad -import Graphics.X11 -import Graphics.X11.Xlib.Extras -import Plugins -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar) -import XUtil (nextEvent') - - -data XMonadLog = XMonadLog | XPropertyLog String - deriving (Read, Show) - -instance Exec XMonadLog where - alias XMonadLog = "XMonadLog" - alias (XPropertyLog atom) = atom - - start x cb = do - let atom = case x of - XMonadLog -> "_XMONAD_LOG" - XPropertyLog a -> a - d <- openDisplay "" - xlog <- internAtom d atom False - - root <- rootWindow d (defaultScreen d) - selectInput d root propertyChangeMask - - let update = do - mwp <- getWindowProperty8 d xlog root - maybe (return ()) (cb . decodeCChar) mwp - - update - - allocaXEvent $ \ep -> forever $ do - nextEvent' d ep - e <- getEvent ep - case e of - PropertyEvent { ev_atom = a } | a == xlog -> update - _ -> return () - - return () - -decodeCChar :: [CChar] -> String -#ifdef UTF8 -#undef UTF8 -decodeCChar = UTF8.decode . map fromIntegral -#define UTF8 -#else -decodeCChar = map (toEnum . fromIntegral) -#endif diff --git a/Plugins/helloworld.config b/Plugins/helloworld.config deleted file mode 100644 index 3818bfa..0000000 --- a/Plugins/helloworld.config +++ /dev/null @@ -1,12 +0,0 @@ -Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , bgColor = "#000000" - , fgColor = "#BFBFBF" - , position = TopW C 90 - , commands = [ Run Cpu [] 10 - , Run Weather "LIPB" [] 36000 - , Run HelloWorld - ] - , sepChar = "%" - , alignSep = "}{" - , template = "%cpu% } %helloWorld% { %LIPB% | %date%" - } diff --git a/Runnable.hs b/Runnable.hs deleted file mode 100644 index 56fedb3..0000000 --- a/Runnable.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Runnable --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The existential type to store the list of commands to be executed. --- I must thank Claus Reinke for the help in understanding the mysteries of --- reading existential types. The Read instance of Runnable must be credited to --- him. --- --- See here: --- http:\/\/www.haskell.org\/pipermail\/haskell-cafe\/2007-July\/028227.html --- ------------------------------------------------------------------------------ - -module Runnable where - -import Control.Monad -import Text.Read -import Config (runnableTypes) -import Commands - -data Runnable = forall r . (Exec r, Read r, Show r) => Run r - -instance Exec Runnable where - start (Run a) = start a - alias (Run a) = alias a - -instance Show Runnable where - show (Run x) = show x - -instance Read Runnable where - readPrec = readRunnable - -class ReadAsAnyOf ts ex where - -- | Reads an existential type as any of hidden types ts - readAsAnyOf :: ts -> ReadPrec ex - -instance ReadAsAnyOf () ex where - readAsAnyOf ~() = mzero - -instance (Show t, Read t, Exec t, ReadAsAnyOf ts Runnable) => ReadAsAnyOf (t,ts) Runnable where - readAsAnyOf ~(t,ts) = r t `mplus` readAsAnyOf ts - where r ty = do { m <- readPrec; return (Run (m `asTypeOf` ty)) } - --- | The 'Prelude.Read' parser for the 'Runnable' existential type. It --- needs an 'Prelude.undefined' with a type signature containing the --- list of all possible types hidden within 'Runnable'. See 'Config.runnableTypes'. --- Each hidden type must have a 'Prelude.Read' instance. -readRunnable :: ReadPrec Runnable -readRunnable = prec 10 $ do - Ident "Run" <- lexP - parens $ readAsAnyOf runnableTypes diff --git a/Runnable.hs-boot b/Runnable.hs-boot deleted file mode 100644 index eba90e6..0000000 --- a/Runnable.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Runnable where -import Commands - -data Runnable = forall r . (Exec r,Read r,Show r) => Run r - -instance Read Runnable -instance Exec Runnable diff --git a/StatFS.hsc b/StatFS.hsc deleted file mode 100644 index 21ee731..0000000 --- a/StatFS.hsc +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : StatFS --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A binding to C's statvfs(2) --- ------------------------------------------------------------------------------ - -{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} - - -module StatFS ( FileSystemStats(..), getFileSystemStats ) where - -import Foreign -import Foreign.C.Types -import Foreign.C.String -import Data.ByteString (useAsCString) -import Data.ByteString.Char8 (pack) - -#if defined (__FreeBSD__) -# include -# include -#else -#include -#endif - -data FileSystemStats = FileSystemStats { - fsStatBlockSize :: Integer - -- ^ Optimal transfer block size. - , fsStatBlockCount :: Integer - -- ^ Total data blocks in file system. - , fsStatByteCount :: Integer - -- ^ Total bytes in file system. - , fsStatBytesFree :: Integer - -- ^ Free bytes in file system. - , fsStatBytesAvailable :: Integer - -- ^ Free bytes available to non-superusers. - , fsStatBytesUsed :: Integer - -- ^ Bytes used. - } deriving (Show, Eq) - -data CStatfs - -#if defined(__FreeBSD__) -foreign import ccall unsafe "sys/mount.h statfs" -#else -foreign import ccall unsafe "sys/vfs.h statfs64" -#endif - c_statfs :: CString -> Ptr CStatfs -> IO CInt - -toI :: CLong -> Integer -toI = toInteger - -getFileSystemStats :: String -> IO (Maybe FileSystemStats) -getFileSystemStats path = - allocaBytes (#size struct statfs) $ \vfs -> - useAsCString (pack path) $ \cpath -> do - res <- c_statfs cpath vfs - if res == -1 then return Nothing - else do - bsize <- (#peek struct statfs, f_bsize) vfs - bcount <- (#peek struct statfs, f_blocks) vfs - bfree <- (#peek struct statfs, f_bfree) vfs - bavail <- (#peek struct statfs, f_bavail) vfs - let bpb = toI bsize - return $ Just FileSystemStats - { fsStatBlockSize = bpb - , fsStatBlockCount = toI bcount - , fsStatByteCount = toI bcount * bpb - , fsStatBytesFree = toI bfree * bpb - , fsStatBytesAvailable = toI bavail * bpb - , fsStatBytesUsed = toI (bcount - bfree) * bpb - } diff --git a/XUtil.hsc b/XUtil.hsc deleted file mode 100644 index d5bb591..0000000 --- a/XUtil.hsc +++ /dev/null @@ -1,259 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : XUtil --- Copyright : (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : andrea.rossato@unitn.it --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module XUtil - ( XFont - , initFont - , initCoreFont - , initUtf8Font - , textExtents - , textWidth - , printString - , initColor - , newWindow - , nextEvent' - , readFileSafe - , hGetLineSafe - , io - , fi - , withColors - , DynPixel(..) - ) where - -import Control.Concurrent -import Control.Monad.Trans -import Data.IORef -import Foreign -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import System.Mem.Weak ( addFinalizer ) -import System.Posix.Types (Fd(..)) -import System.IO -#if defined XFT || defined UTF8 -# if __GLASGOW_HASKELL__ < 612 -import Foreign.C -import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine) -# else -import qualified System.IO as UTF8 (readFile,hGetLine) -# endif -#endif -#if defined XFT -import Data.List -import Graphics.X11.Xft -import Graphics.X11.Xrender -#endif - -readFileSafe :: FilePath -> IO String -#if defined XFT || defined UTF8 -readFileSafe = UTF8.readFile -#else -readFileSafe = readFile -#endif - -hGetLineSafe :: Handle -> IO String -#if defined XFT || defined UTF8 -hGetLineSafe = UTF8.hGetLine -#else -hGetLineSafe = hGetLine -#endif - --- Hide the Core Font/Xft switching here -data XFont = Core FontStruct - | Utf8 FontSet -#ifdef XFT - | Xft XftFont -#endif - --- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend --- Example: 'xft:Sans-10' -initFont :: Display ->String -> IO XFont -initFont d s = -#ifdef XFT - let xftPrefix = "xft:" in - if xftPrefix `isPrefixOf` s then - fmap Xft $ initXftFont d s - else -#endif -#if defined UTF8 || __GLASGOW_HASKELL__ >= 612 - fmap Utf8 $ initUtf8Font d s -#else - fmap Core $ initCoreFont d s -#endif - --- | Given a fontname returns the font structure. If the font name is --- not valid the default font will be loaded and returned. -initCoreFont :: Display -> String -> IO FontStruct -initCoreFont d s = do - f <- catch getIt fallBack - addFinalizer f (freeFont d f) - return f - where getIt = loadQueryFont d s - fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - --- | Given a fontname returns the font structure. If the font name is --- not valid the default font will be loaded and returned. -initUtf8Font :: Display -> String -> IO FontSet -initUtf8Font d s = do - setupLocale - (_,_,f) <- catch getIt fallBack - addFinalizer f (freeFontSet d f) - return f - where getIt = createFontSet d s - fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - -#ifdef XFT -initXftFont :: Display -> String -> IO XftFont -initXftFont d s = do - setupLocale - f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s) - addFinalizer f (xftFontClose d f) - return f -#endif - -textWidth :: Display -> XFont -> String -> IO Int -textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s -textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s -#ifdef XFT -textWidth dpy (Xft xftdraw) s = do - gi <- xftTextExtents dpy xftdraw s - return $ xglyphinfo_xOff gi -#endif - -textExtents :: XFont -> String -> IO (Int32,Int32) -textExtents (Core fs) s = do - let (_,a,d,_) = Xlib.textExtents fs s - return (a,d) -textExtents (Utf8 fs) s = do - let (_,rl) = wcTextExtents fs s - ascent = fi $ - (rect_y rl) - descent = fi $ rect_height rl + (fi $ rect_y rl) - return (ascent, descent) -#ifdef XFT -textExtents (Xft xftfont) _ = do - ascent <- fi `fmap` xftfont_ascent xftfont - descent <- fi `fmap` xftfont_descent xftfont - return (ascent, descent) -#endif - -printString :: Display -> Drawable -> XFont -> GC -> String -> String - -> Position -> Position -> String -> IO () -printString d p (Core fs) gc fc bc x y s = do - setFont d gc $ fontFromFontStruct fs - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - setBackground d gc bc' - drawImageString d p gc x y s - -printString d p (Utf8 fs) gc fc bc x y s = - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - setBackground d gc bc' - io $ wcDrawImageString d p fs gc x y s - -#ifdef XFT -printString dpy drw fs@(Xft font) gc fc bc x y s = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen - withColors dpy [bc] $ \[bcolor] -> do - (a,d) <- textExtents fs s - gi <- xftTextExtents dpy font s - setForeground dpy gc bcolor - fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) - (y - fi (a + d)) - (fi $ xglyphinfo_xOff gi) - (fi $ 4 + a + d) - withXftDraw dpy drw visual colormap $ - \draw -> withXftColorName dpy visual colormap fc $ - \color -> xftDrawString draw color font x (y - 2) s -#endif - -data DynPixel = DynPixel { allocated :: Bool - , pixel :: Pixel - } - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -initColor :: Display -> String -> IO DynPixel -initColor dpy c = (initColor' dpy c) `catch` - (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) - -type ColorCache = [(String, Color)] -{-# NOINLINE colorCache #-} -colorCache :: IORef ColorCache -colorCache = unsafePerformIO $ newIORef [] - -getCachedColor :: String -> IO (Maybe Color) -getCachedColor color_name = lookup color_name `fmap` readIORef colorCache - -putCachedColor :: String -> Color -> IO () -putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c - -initColor' :: Display -> String -> IO DynPixel -initColor' dpy c = do - let colormap = defaultColormap dpy (defaultScreen dpy) - cached_color <- getCachedColor c - c' <- case cached_color of - Just col -> return col - _ -> do (c'', _) <- allocNamedColor dpy colormap c - putCachedColor c c'' - return c'' - return $ DynPixel True (color_pixel c') - -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a -withColors d cs f = do - ps <- mapM (io . initColor d) cs - f $ map pixel ps - --- | Creates a window with the attribute override_redirect set to True. --- Windows Managers should not touch this kind of windows. -newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window -newWindow dpy scr rw (Rectangle x y w h) o = do - let visual = defaultVisualOfScreen scr - attrmask = cWOverrideRedirect - allocaSetWindowAttributes $ - \attributes -> do - set_override_redirect attributes o - createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) - inputOutput visual attrmask attributes --- | A version of nextEvent that does not block in foreign calls. -nextEvent' :: Display -> XEventPtr -> IO () -nextEvent' d p = do - pend <- pending d - if pend /= 0 - then nextEvent d p - else do - threadWaitRead (Fd fd) - nextEvent' d p - where - fd = connectionNumber d - -io :: MonadIO m => IO a -> m a -io = liftIO - --- | Short-hand for 'fromIntegral' -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -#if __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8) -#include -foreign import ccall unsafe "locale.h setlocale" - setlocale :: CInt -> CString -> IO CString - -setupLocale :: IO () -setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return () -# else -setupLocale :: IO () -setupLocale = return () -#endif diff --git a/Xmobar.hs b/Xmobar.hs deleted file mode 100644 index 2f5aa3c..0000000 --- a/Xmobar.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A status bar for the Xmonad Window Manager --- ------------------------------------------------------------------------------ - -module Xmobar - ( -- * Main Stuff - -- $main - X , XConf (..), runX - , eventLoop - -- * Program Execution - -- $command - , startCommand - -- * Window Management - -- $window - , createWin, updateWin - -- * Printing - -- $print - , drawInWin, printStrings - ) where - -import Prelude hiding (catch) -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama - -import Control.Arrow ((&&&)) -import Control.Monad.Reader -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception hiding (handle) -import Data.Bits -import Data.Maybe(fromMaybe) -import Data.Typeable (Typeable) - -import Config -import Parsers -import Commands -import Runnable -import XUtil - --- $main --- --- The Xmobar data type and basic loops and functions. - --- | The X type is a ReaderT -type X = ReaderT XConf IO - --- | The ReaderT inner component -data XConf = - XConf { display :: Display - , rect :: Rectangle - , window :: Window - , fontS :: XFont - , config :: Config - } - --- | Runs the ReaderT -runX :: XConf -> X () -> IO () -runX xc f = runReaderT f xc - -data WakeUp = WakeUp deriving (Show,Typeable) -instance Exception WakeUp - --- | The event loop -eventLoop :: XConf -> [(Maybe ThreadId, TVar String)] -> IO () -eventLoop xc@(XConf d _ w fs c) v = block $ do - tv <- atomically $ newTVar [] - t <- myThreadId - ct <- forkIO (checker t tv "" `catch` \(SomeException _) -> return ()) - go tv ct - where - -- interrupt the drawing thread every time a var is updated - checker t tvar ov = do - nval <- atomically $ do - nv <- fmap concat $ mapM readTVar (map snd v) - guard (nv /= ov) - writeTVar tvar nv - return nv - throwTo t WakeUp - checker t tvar nval - - -- Continuously wait for a timer interrupt or an expose event - go tv ct = do - catch (unblock $ allocaXEvent $ \e -> - handle tv ct =<< (nextEvent' d e >> getEvent e)) - (\WakeUp -> runX xc (updateWin tv) >> return ()) - go tv ct - - -- event hanlder - handle _ ct (ConfigureEvent {ev_window = win}) = do - rootw <- rootWindow d (defaultScreen d) - when (win == rootw) $ block $ do - killThread ct - destroyWindow d w - (r',w') <- createWin d fs c - eventLoop (XConf d r' w' fs c) v - - handle tvar _ (ExposeEvent {}) = runX xc (updateWin tvar) - - handle _ _ _ = return () - --- $command - --- | Runs a command as an independent thread and returns its thread id --- and the TVar the command will be writing to. -startCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, TVar String) -startCommand (com,s,ss) - | alias com == "" = do var <- atomically $ newTVar is - atomically $ writeTVar var "Could not parse the template" - return (Nothing,var) - | otherwise = do var <- atomically $ newTVar is - let cb str = atomically $ writeTVar var (s ++ str ++ ss) - h <- forkIO $ start com cb - return (Just h,var) - where is = s ++ "Updating..." ++ ss - --- $window - --- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) -createWin d fs c = do - let dflt = defaultScreen d - srs <- getScreenInfo d - rootw <- rootWindow d dflt - (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - (r,o) = setPosition (position c) srs (fi ht) - win <- newWindow d (defaultScreenOfDisplay d) rootw r o - selectInput d win (exposureMask .|. structureNotifyMask) - setProperties r c d win srs - when (lowerOnStart c) (lowerWindow d win) - mapWindow d win - return (r,win) - -setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) -setPosition p rs ht = - case p' of - Top -> (Rectangle rx ry rw h , True) - TopW a i -> (Rectangle (ax a i ) ry (nw i ) h , True) - TopSize a i ch -> (Rectangle (ax a i ) ry (nw i ) (mh ch), True) - Bottom -> (Rectangle rx ny rw h , True) - BottomW a i -> (Rectangle (ax a i ) ny (nw i ) h , True) - BottomSize a i ch -> (Rectangle (ax a i ) ny (nw i ) (mh ch), True) - Static cx cy cw ch -> (Rectangle (fi cx ) (fi cy) (fi cw) (fi ch), True) - OnScreen _ p'' -> setPosition p'' [scr] ht - where - (scr@(Rectangle rx ry rw rh), p') = - case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) - _ -> (head rs, p) - ny = ry + fi (rh - ht) - center i = rx + (fi $ div (remwid i) 2) - right i = rx + (fi $ remwid i) - remwid i = rw - pw (fi i) - ax L = const rx - ax R = right - ax C = center - pw i = rw * (min 100 i) `div` 100 - nw = fi . pw . fi - h = fi ht - mh h' = max (fi h') h - - safeIndex i = lookup i . zip [0..] - -setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () -setProperties r c d w srs = do - a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False - c1 <- internAtom d "CARDINAL" False - a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False - c2 <- internAtom d "ATOM" False - v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False - changeProperty32 d w a1 c1 propModeReplace $ map fi $ - getStrutValues r (position c) (getRootWindowHeight srs) - changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] - -getRootWindowHeight :: [Rectangle] -> Int -getRootWindowHeight srs = foldr1 max (map getMaxScreenYCoord srs) - where - getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) - -getStrutValues :: Rectangle -> XPosition -> Int -> [Int] -getStrutValues r@(Rectangle x y w h) p rwh = - case p of - OnScreen _ p' -> getStrutValues r p' rwh - Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - Static _ _ _ _ -> getStaticStrutValues p rwh - where st = fi y + fi h - sb = rwh - fi y - nx = fi x - nw = fi (x + fi w - 1) - --- get some reaonable strut values for static placement. -getStaticStrutValues :: XPosition -> Int -> [Int] -getStaticStrutValues (Static cx cy cw ch) rwh - -- if the yPos is in the top half of the screen, then assume a Top - -- placement, otherwise, it's a Bottom placement - | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] - | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] - where st = cy + ch - sb = rwh - cy - xs = cx -- a simple calculation for horizontal (x) placement - xe = xs + cw -getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - -updateWin :: TVar String -> X () -updateWin v = do - xc <- ask - let (conf,rec) = (config &&& rect) xc - [lc,rc] = if length (alignSep conf) == 2 - then alignSep conf - else alignSep defaultConfig - i <- io $ atomically $ readTVar v - let def = [i,[],[]] - [l,c,r] = case break (==lc) i of - (le,_:re) -> case break (==rc) re of - (ce,_:ri) -> [le,ce,ri] - _ -> def - _ -> def - ps <- io $ mapM (parseString conf) [l,c,r] - drawInWin rec ps - --- $print - --- | Draws in and updates the window -drawInWin :: Rectangle -> [[(String, String)]] -> X () -drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do - r <- ask - let (c,d ) = (config &&& display) r - (w,fs) = (window &&& fontS ) r - strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw)) - withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do - gc <- io $ createGC d w - -- create a pixmap to write to and fill it with a rectangle - p <- io $ createPixmap d w wid ht - (defaultDepthOfScreen (defaultScreenOfDisplay d)) - -- the fgcolor of the rectangle will be the bgcolor of the window - io $ setForeground d gc bgcolor - io $ fillRectangle d p gc 0 0 wid ht - -- write to the pixmap the new string - printStrings p gc fs 1 L =<< strLn left - printStrings p gc fs 1 R =<< strLn right - printStrings p gc fs 1 C =<< strLn center - -- draw 1 pixel border if requested - io $ drawBorder (border c) d p gc bdcolor wid ht - -- copy the pixmap with the new string to the window - io $ copyArea d p w gc 0 0 wid ht 0 0 - -- free up everything (we do not want to leak memory!) - io $ freeGC d gc - io $ freePixmap d p - -- resync - io $ sync d True - -drawBorder :: Border -> Display -> Drawable -> GC -> Pixel -> Dimension - -> Dimension -> IO () -drawBorder b d p gc c wi ht = case b of - NoBorder -> return () - TopB -> drawBorder (TopBM 0) d p gc c w h - BottomB -> drawBorder (BottomBM 0) d p gc c w h - FullB -> drawBorder (FullBM 0) d p gc c w h - TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 - BottomBM m -> let rw = (fi h) - (fi m) in - sf >> drawLine d p gc 0 rw (fi w) rw - FullBM m -> let rm = fi m; mp = fi m in - sf >> drawRectangle d p gc mp mp (w - rm) (h - rm) - where sf = setForeground d gc c - (w, h) = (wi - 1, ht - 1) - --- | An easy way to print the stuff we need to print -printStrings :: Drawable -> GC -> XFont -> Position - -> Align -> [(String, String, Position)] -> X () -printStrings _ _ _ _ _ [] = return () -printStrings dr gc fontst offs a sl@((s,c,l):xs) = do - r <- ask - (as,ds) <- io $ textExtents fontst s - let (conf,d) = (config &&& display) r - Rectangle _ _ wid ht = rect r - totSLen = foldr (\(_,_,len) -> (+) len) 0 sl - valign = fi $ as + ds - remWidth = fi wid - fi totSLen - offset = case a of - C -> (remWidth + offs) `div` 2 - R -> remWidth - L -> offs - (fc,bc) = case (break (==',') c) of - (f,',':b) -> (f, b ) - (f, _) -> (f, bgColor conf) - withColors d [bc] $ \[bc'] -> do - io $ setForeground d gc bc' - io $ fillRectangle d dr gc offset 0 (fi l) ht - io $ printString d dr fontst gc fc bc offset valign s - printStrings dr gc fontst (offs + l) a xs diff --git a/src/Commands.hs b/src/Commands.hs new file mode 100644 index 0000000..d205dbf --- /dev/null +++ b/src/Commands.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Commands +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- The 'Exec' class and the 'Command' data type. +-- +-- The 'Exec' class rappresents the executable types, whose constructors may +-- appear in the 'Config.commands' field of the 'Config.Config' data type. +-- +-- The 'Command' data type is for OS commands to be run by xmobar +-- +----------------------------------------------------------------------------- + +module Commands + ( Command (..) + , Exec (..) + , tenthSeconds + ) where + +import Prelude hiding (catch) +import Control.Concurrent +import Control.Exception +import Data.Char +import System.Process +import System.Exit +import System.IO (hClose) +import XUtil + +class Show e => Exec e where + alias :: e -> String + alias e = takeWhile (not . isSpace) $ show e + rate :: e -> Int + rate _ = 10 + run :: e -> IO String + run _ = return "" + start :: e -> (String -> IO ()) -> IO () + start e cb = go + where go = do + run e >>= cb + tenthSeconds (rate e) >> go + +data Command = Com Program Args Alias Rate + deriving (Show,Read,Eq) + +type Args = [String] +type Program = String +type Alias = String +type Rate = Int + +instance Exec Command where + alias (Com p _ a _) + | p /= "" = if a == "" then p else a + | otherwise = "" + start (Com prog args _ r) cb = if r > 0 then go else exec + where go = exec >> tenthSeconds r >> go + exec = do + (i,o,e,p) <- runInteractiveCommand (unwords (prog:args)) + exit <- waitForProcess p + let closeHandles = hClose o >> hClose i >> hClose e + case exit of + ExitSuccess -> do + str <- catch (hGetLineSafe o) + (\(SomeException _) -> return "") + closeHandles + cb str + _ -> do closeHandles + cb $ "Could not execute command " ++ prog + + +-- | Work around to the Int max bound: since threadDelay takes an Int, it +-- is not possible to set a thread delay grater than about 45 minutes. +-- With a little recursion we solve the problem. +tenthSeconds :: Int -> IO () +tenthSeconds s | s >= x = do threadDelay y + tenthSeconds (x - s) + | otherwise = threadDelay (s * 100000) + where y = maxBound :: Int + x = y `div` 100000 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..6eb55a0 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP, TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Config +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- The configuration module of Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Config + ( -- * Configuration + -- $config + Config (..) + , XPosition (..), Align (..), Border(..) + , defaultConfig + , runnableTypes + ) where + +import Commands +import {-# SOURCE #-} Runnable +import Plugins.Monitors +import Plugins.Date +import Plugins.PipeReader +import Plugins.CommandReader +import Plugins.StdinReader +import Plugins.XMonadLog +import Plugins.EWMH + +#ifdef INOTIFY +import Plugins.Mail +import Plugins.MBox +#endif + +-- $config +-- Configuration data type and default configuration + +-- | The configuration data type +data Config = + Config { font :: String -- ^ Font + , bgColor :: String -- ^ Backgroud color + , fgColor :: String -- ^ Default font color + , position :: XPosition -- ^ Top Bottom or Static + , border :: Border -- ^ NoBorder TopB BottomB or FullB + , borderColor :: String -- ^ Border color + , lowerOnStart :: Bool -- ^ Lower to the bottom of the + -- window stack on initialization + , commands :: [Runnable] -- ^ For setting the command, the command arguments + -- and refresh rate for the programs to run (optional) + , sepChar :: String -- ^ The character to be used for indicating + -- commands in the output template (default '%') + , alignSep :: String -- ^ Separators for left, center and right text alignment + , template :: String -- ^ The output template + } deriving (Read) + +data XPosition = Top + | TopW Align Int + | TopSize Align Int Int + | Bottom + | BottomW Align Int + | BottomSize Align Int Int + | Static {xpos, ypos, width, height :: Int} + | OnScreen Int XPosition + deriving ( Read, Eq ) + +data Align = L | R | C deriving ( Read, Eq ) + +data Border = NoBorder + | TopB + | BottomB + | FullB + | TopBM Int + | BottomBM Int + | FullBM Int + deriving ( Read, Eq ) + +-- | The default configuration values +defaultConfig :: Config +defaultConfig = + Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , bgColor = "#000000" + , fgColor = "#BFBFBF" + , position = Top + , border = NoBorder + , borderColor = "#BFBFBF" + , lowerOnStart = True + , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 + , Run StdinReader] + , sepChar = "%" + , alignSep = "}{" + , template = "%StdinReader% }{ %uname% * %theDate%" + } + + +-- | An alias for tuple types that is more convenient for long lists. +type a :*: b = (a, b) +infixr :*: + +-- | This is the list of types that can be hidden inside +-- 'Runnable.Runnable', the existential type that stores all commands +-- to be executed by Xmobar. It is used by 'Runnable.readRunnable' in +-- the 'Runnable.Runnable' Read instance. To install a plugin just add +-- the plugin's type to the list of types (separated by ':*:') appearing in +-- this function's type signature. +runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: +#ifdef INOTIFY + Mail :*: MBox :*: +#endif + () +runnableTypes = undefined diff --git a/src/IWlib.hsc b/src/IWlib.hsc new file mode 100644 index 0000000..5f7754d --- /dev/null +++ b/src/IWlib.hsc @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- | +-- Module : IWlib +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A partial binding to iwlib +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} + + +module IWlib (WirelessInfo(..), getWirelessInfo) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +data WirelessInfo = WirelessInfo { wiEssid :: String, wiQuality :: Int } + deriving Show + +#include + +data WCfg +data WStats +data WRange + +foreign import ccall "iwlib.h iw_sockets_open" + c_iw_open :: IO CInt + +foreign import ccall "unistd.h close" + c_iw_close :: CInt -> IO () + +foreign import ccall "iwlib.h iw_get_basic_config" + c_iw_basic_config :: CInt -> CString -> Ptr WCfg -> IO CInt + +foreign import ccall "iwlib.h iw_get_stats" + c_iw_stats :: CInt -> CString -> Ptr WStats -> Ptr WRange -> CInt -> IO CInt + +foreign import ccall "iwlib.h iw_get_range_info" + c_iw_range :: CInt -> CString -> Ptr WRange -> IO CInt + +getWirelessInfo :: String -> IO WirelessInfo +getWirelessInfo iface = + allocaBytes (#size struct wireless_config) $ \wc -> + allocaBytes (#size struct iw_statistics) $ \stats -> + allocaBytes (#size struct iw_range) $ \rng -> + withCString iface $ \istr -> do + i <- c_iw_open + bcr <- c_iw_basic_config i istr wc + str <- c_iw_stats i istr stats rng 1 + rgr <- c_iw_range i istr rng + c_iw_close i + if (bcr < 0) then return WirelessInfo { wiEssid = "", wiQuality = 0 } else + do hase <- (#peek struct wireless_config, has_essid) wc :: IO CInt + eon <- (#peek struct wireless_config, essid_on) wc :: IO CInt + essid <- if hase /= 0 && eon /= 0 then + do let e = (#ptr struct wireless_config, essid) wc + peekCString e + else return "" + q <- if str >= 0 && rgr >=0 then + do qualv <- xqual $ (#ptr struct iw_statistics, qual) stats + mv <- xqual $ (#ptr struct iw_range, max_qual) rng + let mxv = if mv /= 0 then fromIntegral mv else 1 + return $ fromIntegral qualv / mxv + else return 0 + let qv = round (100 * (q :: Double)) + return $ WirelessInfo { wiEssid = essid, wiQuality = min 100 qv } + where xqual p = let qp = (#ptr struct iw_param, value) p in + (#peek struct iw_quality, qual) qp :: IO CChar diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..2719a79 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Main +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- The main module of Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Main ( -- * Main Stuff + -- $main + main + , readConfig + , readDefaultConfig + ) where + +import Xmobar +import Parsers +import Config +import XUtil + +import Data.List (intercalate) + +import Paths_xmobar (version) +import Data.IORef +import Data.Version (showVersion) +import Graphics.X11.Xlib +import System.Console.GetOpt +import System.Exit +import System.Environment +import System.Posix.Files +import Control.Monad (unless) + +-- $main + +-- | The main entry point +main :: IO () +main = do + d <- openDisplay "" + args <- getArgs + (o,file) <- getOpts args + (c,defaultings) <- case file of + [cfgfile] -> readConfig cfgfile + _ -> readDefaultConfig + + unless (null defaultings) $ putStrLn $ "Fields missing from config defaulted: " + ++ intercalate "," defaultings + + -- listen for ConfigureEvents on the root window, for xrandr support: + rootw <- rootWindow d (defaultScreen d) + selectInput d rootw structureNotifyMask + + civ <- newIORef c + doOpts civ o + conf <- readIORef civ + fs <- initFont d (font conf) + cl <- parseTemplate conf (template conf) + vars <- mapM startCommand cl + (r,w) <- createWin d fs conf + eventLoop (XConf d r w fs conf) vars + +-- | Reads the configuration files or quits with an error +readConfig :: FilePath -> IO (Config,[String]) +readConfig f = do + file <- io $ fileExist f + s <- io $ if file then readFileSafe f else error $ f ++ ": file not found!\n" ++ usage + either (\err -> error $ f ++ ": configuration file contains errors at:\n" ++ show err) + return $ parseConfig s + +-- | Read default configuration file or load the default config +readDefaultConfig :: IO (Config,[String]) +readDefaultConfig = do + home <- io $ getEnv "HOME" + let path = home ++ "/.xmobarrc" + f <- io $ fileExist path + if f then readConfig path else return (defaultConfig,[]) + +data Opts = Help + | Version + | Font String + | BgColor String + | FgColor String + | T + | B + | AlignSep String + | Commands String + | SepChar String + | Template String + | OnScr String + deriving Show + +options :: [OptDescr Opts] +options = + [ Option ['h','?' ] ["help" ] (NoArg Help ) "This help" + , Option ['V' ] ["version" ] (NoArg Version ) "Show version information" + , Option ['f' ] ["font" ] (ReqArg Font "font name") "The font name" + , Option ['B' ] ["bgcolor" ] (ReqArg BgColor "bg color" ) "The background color. Default black" + , Option ['F' ] ["fgcolor" ] (ReqArg FgColor "fg color" ) "The foreground color. Default grey" + , Option ['o' ] ["top" ] (NoArg T ) "Place xmobar at the top of the screen" + , Option ['b' ] ["bottom" ] (NoArg B ) "Place xmobar at the bottom of the screen" + , Option ['a' ] ["alignsep" ] (ReqArg AlignSep "alignsep" ) "Separators for left, center and right text\nalignment. Default: '}{'" + , Option ['s' ] ["sepchar" ] (ReqArg SepChar "char" ) "The character used to separate commands in\nthe output template. Default '%'" + , Option ['t' ] ["template" ] (ReqArg Template "template" ) "The output template" + , Option ['c' ] ["commands" ] (ReqArg Commands "commands" ) "The list of commands to be executed" + , Option ['x' ] ["screen" ] (ReqArg OnScr "screen" ) "On which X screen number to start" + ] + +getOpts :: [String] -> IO ([Opts], [String]) +getOpts argv = + case getOpt Permute options argv of + (o,n,[]) -> return (o,n) + (_,_,errs) -> error (concat errs ++ usage) + +usage :: String +usage = (usageInfo header options) ++ footer + where header = "Usage: xmobar [OPTION...] [FILE]\nOptions:" + footer = "\nMail bug reports and suggestions to " ++ mail ++ "\n" + +info :: String +info = "xmobar " ++ showVersion version + ++ "\n (C) 2007 - 2010 Andrea Rossato " + ++ "\n (C) 2010 Jose A Ortega Ruiz\n " + ++ mail ++ "\n" ++ license + +mail :: String +mail = "" + +license :: String +license = "\nThis program is distributed in the hope that it will be useful,\n" ++ + "but WITHOUT ANY WARRANTY; without even the implied warranty of\n" ++ + "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n" ++ + "See the License for more details." + +doOpts :: IORef Config -> [Opts] -> IO () +doOpts _ [] = return () +doOpts conf (o:oo) = + case o of + Help -> putStr usage >> exitWith ExitSuccess + Version -> putStrLn info >> exitWith ExitSuccess + Font s -> modifyIORef conf (\c -> c { font = s }) >> go + BgColor s -> modifyIORef conf (\c -> c { bgColor = s }) >> go + FgColor s -> modifyIORef conf (\c -> c { fgColor = s }) >> go + T -> modifyIORef conf (\c -> c { position = Top }) >> go + B -> modifyIORef conf (\c -> c { position = Bottom}) >> go + AlignSep s -> modifyIORef conf (\c -> c { alignSep = s }) >> go + SepChar s -> modifyIORef conf (\c -> c { sepChar = s }) >> go + Template s -> modifyIORef conf (\c -> c { template = s }) >> go + OnScr n -> modifyIORef conf (\c -> c { position = OnScreen (read n) $ position c }) >> go + Commands s -> case readCom s of + Right x -> modifyIORef conf (\c -> c { commands = x }) >> go + Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) + where readCom str = + case readStr str of + [x] -> Right x + _ -> Left "xmobar: cannot read list of commands specified with the -c option\n" + readStr str = + [x | (x,t) <- reads str, ("","") <- lex t] + go = doOpts conf oo diff --git a/src/Parsers.hs b/src/Parsers.hs new file mode 100644 index 0000000..1450a0e --- /dev/null +++ b/src/Parsers.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Parsers +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- Parsers needed for Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Parsers + ( parseString + , parseTemplate + , parseConfig + ) where + +import Config +import Runnable +import Commands + +import qualified Data.Map as Map +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Perm + +-- | Runs the string parser +parseString :: Config -> String -> IO [(String, String)] +parseString c s = + case parse (stringParser (fgColor c)) "" s of + Left _ -> return [("Could not parse string: " ++ s, fgColor c)] + Right x -> return (concat x) + +-- | Gets the string and combines the needed parsers +stringParser :: String -> Parser [[(String, String)]] +stringParser c = manyTill (textParser c <|> colorParser) eof + +-- | Parses a maximal string without color markup. +textParser :: String -> Parser [(String, String)] +textParser c = do s <- many1 $ + noneOf "<" <|> + ( try $ notFollowedBy' (char '<') + (string "fc=" <|> string "/fc>" ) ) + return [(s, c)] + +-- | Wrapper for notFollowedBy that returns the result of the first parser. +-- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy +-- accepts only parsers with return type Char. +notFollowedBy' :: Parser a -> Parser b -> Parser a +notFollowedBy' p e = do x <- p + notFollowedBy $ try (e >> return '*') + return x + +-- | Parsers a string wrapped in a color specification. +colorParser :: Parser [(String, String)] +colorParser = do + c <- between (string "") colors + s <- manyTill (textParser c <|> colorParser) (try $ string "") + return (concat s) + +-- | Parses a color specification (hex or named) +colors :: Parser String +colors = many1 (alphaNum <|> char ',' <|> char '#') + +-- | Parses the output template string +templateStringParser :: Config -> Parser (String,String,String) +templateStringParser c = do + s <- allTillSep c + com <- templateCommandParser c + ss <- allTillSep c + return (com, s, ss) + +-- | Parses the command part of the template string +templateCommandParser :: Config -> Parser String +templateCommandParser c = + let chr = char . head . sepChar + in between (chr c) (chr c) (allTillSep c) + +-- | Combines the template parsers +templateParser :: Config -> Parser [(String,String,String)] +templateParser = many . templateStringParser + +-- | Actually runs the template parsers +parseTemplate :: Config -> String -> IO [(Runnable,String,String)] +parseTemplate c s = + do str <- case parse (templateParser c) "" s of + Left _ -> return [("","","")] + Right x -> return x + let cl = map alias (commands c) + m = Map.fromList $ zip cl (commands c) + return $ combine c m str + +-- | Given a finite "Map" and a parsed template produce the resulting +-- output string. +combine :: Config -> Map.Map String Runnable -> [(String, String, String)] -> [(Runnable,String,String)] +combine _ _ [] = [] +combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs + where com = Map.findWithDefault dflt ts m + dflt = Run $ Com ts [] [] 10 + +allTillSep :: Config -> Parser String +allTillSep = many . noneOf . sepChar + +stripComments :: String -> String +stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines + where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else "" + strip m ('\\':xss) = case xss of + '\\':xs -> '\\' : strip m xs + _ -> strip m $ drop 1 xss + strip m ('"':xs) = '"': strip (not m) xs + strip m (x:xs) = x : strip m xs + strip _ [] = [] + +-- | Parse the config, logging a list of fields that were missing and replaced +-- by the default definition. +parseConfig :: String -> Either ParseError (Config,[String]) +parseConfig = runParser parseConf fields "Config" . stripComments + where + parseConf = do + many space + sepEndSpc ["Config","{"] + x <- perms + eof + s <- getState + return (x,s) + + perms = permute $ Config + <$?> pFont <|?> pBgColor + <|?> pFgColor <|?> pPosition + <|?> pBorder <|?> pBdColor + <|?> pLowerOnStart <|?> pCommands + <|?> pSepChar <|?> pAlignSep + <|?> pTemplate + + fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" + , "border", "borderColor" ,"template", "position" + , "lowerOnStart", "commands"] + pFont = strField font "font" + pBgColor = strField bgColor "bgColor" + pFgColor = strField fgColor "fgColor" + pBdColor = strField borderColor "borderColor" + pSepChar = strField sepChar "sepChar" + pAlignSep = strField alignSep "alignSep" + pTemplate = strField template "template" + + pPosition = field position "position" $ tillFieldEnd >>= read' "position" + pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart" + pBorder = field border "border" $ tillFieldEnd >>= read' "border" + pCommands = field commands "commands" $ readCommands + + staticPos = do string "Static" + wrapSkip (string "{") + p <- many (noneOf "}") + wrapSkip (string "}") + string "," + return ("Static {" ++ p ++ "}") + tillFieldEnd = staticPos <|> many (noneOf ",}\n\r") + + commandsEnd = wrapSkip (string "]") >> oneOf "}," + readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]" + + strField e n = field e n . between (strDel "start" n) (strDel "end" n) . many $ noneOf "\"\n\r" + strDel t n = char '"' strErr t n + strErr t n = "the " ++ t ++ " of the string field " ++ n ++ " - a double quote (\")." + + wrapSkip x = many space >> x >>= \r -> many space >> return r + sepEndSpc = mapM_ (wrapSkip . try . string) + fieldEnd = many $ space <|> oneOf ",}" + field e n c = (,) (e defaultConfig) $ + updateState (filter (/= n)) >> sepEndSpc [n,"="] >> + wrapSkip c >>= \r -> fieldEnd >> return r + + read' d s = case reads s of + [(x, _)] -> return x + _ -> fail $ "error reading the " ++ d ++ " field: " ++ s + +commandsErr :: String +commandsErr = "commands: this usually means that a command could not be parsed.\n" ++ + "The error could be located at the begining of the command which follows the offending one." + diff --git a/src/Plugins.hs b/src/Plugins.hs new file mode 100644 index 0000000..4255244 --- /dev/null +++ b/src/Plugins.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Plugins +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- This module exports the API for plugins. +-- +-- Have a look at Plugins\/HelloWorld.hs +-- +----------------------------------------------------------------------------- + +module Plugins + ( Exec (..) + , tenthSeconds + , readFileSafe + , hGetLineSafe + ) where + +import Commands +import XUtil diff --git a/src/Plugins/CommandReader.hs b/src/Plugins/CommandReader.hs new file mode 100644 index 0000000..7c7c92d --- /dev/null +++ b/src/Plugins/CommandReader.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.CommandReader +-- Copyright : (c) John Goerzen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from external commands +-- note: stderr is lost here +-- +----------------------------------------------------------------------------- + +module Plugins.CommandReader where + +import System.IO +import Plugins +import System.Process(runInteractiveCommand, getProcessExitCode) + +data CommandReader = CommandReader String String + deriving (Read, Show) + +instance Exec CommandReader where + alias (CommandReader _ a) = a + start (CommandReader p _) cb = do + (hstdin, hstdout, hstderr, ph) <- runInteractiveCommand p + hClose hstdin + hClose hstderr + hSetBinaryMode hstdout False + hSetBuffering hstdout LineBuffering + forever ph (hGetLineSafe hstdout >>= cb) + where forever ph a = + do a + ec <- getProcessExitCode ph + case ec of + Nothing -> forever ph a + Just _ -> cb "EXITED" diff --git a/src/Plugins/Date.hs b/src/Plugins/Date.hs new file mode 100644 index 0000000..bfcb132 --- /dev/null +++ b/src/Plugins/Date.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Date +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A date plugin for Xmobar +-- +-- Usage example: in template put +-- +-- > Run Date "%a %b %_d %Y %H:%M:%S" "Mydate" 10 +-- +----------------------------------------------------------------------------- + +module Plugins.Date (Date(..)) where + +import Plugins + +import System.Locale +import System.Time + +data Date = Date String String Int + deriving (Read, Show) + +instance Exec Date where + alias (Date _ a _) = a + run (Date f _ _) = date f + rate (Date _ _ r) = r + +date :: String -> IO String +date format = do + t <- toCalendarTime =<< getClockTime + return $ formatCalendarTime defaultTimeLocale format t diff --git a/src/Plugins/EWMH.hs b/src/Plugins/EWMH.hs new file mode 100644 index 0000000..d5b70cb --- /dev/null +++ b/src/Plugins/EWMH.hs @@ -0,0 +1,264 @@ +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.EWMH +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen +-- Stability : unstable +-- Portability : unportable +-- +-- An experimental plugin to display EWMH pager information +-- +----------------------------------------------------------------------------- + +module Plugins.EWMH (EWMH(..)) where + +import Control.Monad.State +import Control.Monad.Reader +import Graphics.X11 hiding (Modifier, Color) +import Graphics.X11.Xlib.Extras +import Plugins +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar, CLong) +import XUtil (nextEvent') + +import Data.List (intersperse, intercalate) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +data EWMH = EWMH | EWMHFMT Component deriving (Read, Show) + +instance Exec EWMH where + alias EWMH = "EWMH" + + start ew cb = allocaXEvent $ \ep -> execM $ do + d <- asks display + r <- asks root + + liftIO xSetErrorHandler + + liftIO $ selectInput d r propertyChangeMask + handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers + mapM_ ((=<< asks root) . snd) handlers' + + forever $ do + liftIO . cb . fmtOf ew =<< get + liftIO $ nextEvent' d ep + e <- liftIO $ getEvent ep + case e of + PropertyEvent { ev_atom = a, ev_window = w } -> do + case lookup a handlers' of + Just f -> f w + _ -> return () + _ -> return () + + return () + +defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty] + , Layout + , Color "#00ee00" "" :$ Short 120 :$ WindowName] + +fmtOf EWMH = flip fmt defaultPP +fmtOf (EWMHFMT f) = flip fmt f + +sep :: [a] -> [[a]] -> [a] +sep x xs = intercalate x $ filter (not . null) xs + +fmt :: EwmhState -> Component -> String +fmt e (Text s) = s +fmt e (l :+ r) = fmt e l ++ fmt e r +fmt e (m :$ r) = modifier m $ fmt e r +fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs +fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e) +fmt e Layout = layout e +fmt e (Workspaces opts) = sep " " + [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as] + | (n, as) <- attrs] + where + stats i = [ (Current, i == currentDesktop e) + , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e) + -- TODO for visible , (Visibl + ] + attrs :: [(String, [WsType])] + attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)] + nonEmptys = Set.unions . map desktops . Map.elems $ clients e + +modifier :: Modifier -> (String -> String) +modifier Hide = const "" +modifier (Color fg bg) = \x -> concat ["", x, ""] +modifier (Short n) = take n +modifier (Wrap l r) = \x -> l ++ x ++ r + +data Component = Text String + | Component :+ Component + | Modifier :$ Component + | Sep Component [Component] + | WindowName + | Layout + | Workspaces [WsOpt] + deriving (Read, Show) + +infixr 0 :$ +infixr 5 :+ + +data Modifier = Hide + | Color String String + | Short Int + | Wrap String String + deriving (Read, Show) + +data WsOpt = Modifier :% WsType + | WSep Component + deriving (Read, Show) +infixr 0 :% + +data WsType = Current | Empty | Visible + deriving (Read, Show, Eq) + +data EwmhConf = C { root :: Window + , display :: Display } + +data EwmhState = S { currentDesktop :: CLong + , activeWindow :: Window + , desktopNames :: [String] + , layout :: String + , clients :: Map Window Client } + deriving Show + +data Client = Cl { windowName :: String + , desktops :: Set CLong } + deriving Show + +getAtom :: String -> M Atom +getAtom s = do + d <- asks display + liftIO $ internAtom d s False + +windowProperty32 :: String -> Window -> M (Maybe [CLong]) +windowProperty32 s w = do + (C {display}) <- ask + a <- getAtom s + liftIO $ getWindowProperty32 display a w + +windowProperty8 :: String -> Window -> M (Maybe [CChar]) +windowProperty8 s w = do + (C {display}) <- ask + a <- getAtom s + liftIO $ getWindowProperty8 display a w + +initialState :: EwmhState +initialState = S 0 0 [] [] Map.empty + +initialClient :: Client +initialClient = Cl "" Set.empty + +handlers, clientHandlers :: [(String, Updater)] +handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop) + , ("_NET_DESKTOP_NAMES", updateDesktopNames ) + , ("_NET_ACTIVE_WINDOW", updateActiveWindow) + , ("_NET_CLIENT_LIST", updateClientList) + ] ++ clientHandlers + +clientHandlers = [ ("_NET_WM_NAME", updateName) + , ("_NET_WM_DESKTOP", updateDesktop) ] + +newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a) + deriving (Monad, Functor, MonadIO, MonadReader EwmhConf, MonadState EwmhState) + +execM :: M a -> IO a +execM (M m) = do + d <- openDisplay "" + r <- rootWindow d (defaultScreen d) + let conf = C r d + evalStateT (runReaderT m (C r d)) initialState + +type Updater = Window -> M () + +updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater +updateCurrentDesktop _ = do + (C {root}) <- ask + mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root + case mwp of + Just [x] -> modify (\s -> s { currentDesktop = x }) + _ -> return () + +updateActiveWindow _ = do + (C {root}) <- ask + mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root + case mwp of + Just [x] -> modify (\s -> s { activeWindow = fromIntegral x }) + _ -> return () + +updateDesktopNames _ = do + (C {root}) <- ask + mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root + case mwp of + Just xs -> modify (\s -> s { desktopNames = parse xs }) + _ -> return () + where + dropNull ('\0':xs) = xs + dropNull xs = xs + + split [] = [] + split xs = case span (/= '\0') xs of + (x, ys) -> x : split (dropNull ys) + parse = split . decodeCChar + +updateClientList _ = do + (C {root}) <- ask + mwp <- windowProperty32 "_NET_CLIENT_LIST" root + case mwp of + Just xs -> do + cl <- gets clients + let cl' = Map.fromList $ map (flip (,) initialClient . fromIntegral) xs + dels = Map.difference cl cl' + new = Map.difference cl' cl + modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'}) + mapM_ unmanage (map fst $ Map.toList dels) + mapM_ listen (map fst $ Map.toList cl') + mapM_ update (map fst $ Map.toList new) + _ -> return () + where + unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0 + listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask + update w = mapM_ (($ w) . snd) clientHandlers + +modifyClient :: Window -> (Client -> Client) -> M () +modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s }) + where + f' Nothing = Just $ f initialClient + f' (Just x) = Just $ f x + +updateName w = do + mwp <- windowProperty8 "_NET_WM_NAME" w + case mwp of + Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs }) + _ -> return () + +updateDesktop w = do + mwp <- windowProperty32 "_NET_WM_DESKTOP" w + case mwp of + Just x -> modifyClient w (\c -> c { desktops = Set.fromList x }) + _ -> return () + +decodeCChar :: [CChar] -> String +#ifdef UTF8 +#undef UTF8 +decodeCChar = UTF8.decode . map fromIntegral +#define UTF8 +#else +decodeCChar = map (toEnum . fromIntegral) +#endif diff --git a/src/Plugins/HelloWorld.hs b/src/Plugins/HelloWorld.hs new file mode 100644 index 0000000..df5cff6 --- /dev/null +++ b/src/Plugins/HelloWorld.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.HelloWorld +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin example for Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Plugins.HelloWorld where + +import Plugins + +data HelloWorld = HelloWorld + deriving (Read, Show) + +instance Exec HelloWorld where + alias HelloWorld = "helloWorld" + run HelloWorld = return "Hello World!!" diff --git a/src/Plugins/MBox.hs b/src/Plugins/MBox.hs new file mode 100644 index 0000000..65a8bb3 --- /dev/null +++ b/src/Plugins/MBox.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.MBox +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for checking mail in mbox files. +-- +----------------------------------------------------------------------------- + +module Plugins.MBox (MBox(..)) where + +import Prelude hiding (catch) +import Plugins +import Plugins.Utils (changeLoop, expandHome) + +import Control.Monad (when) +import Control.Concurrent.STM +import Control.Exception (SomeException, handle, evaluate) + +import System.Console.GetOpt +import System.Directory (doesFileExist) +import System.FilePath (()) +import System.INotify (Event(..), EventVariety(..), initINotify, addWatch) + +import qualified Data.ByteString.Lazy.Char8 as B + +data Options = Options + { oAll :: Bool + , oUniq :: Bool + , oDir :: FilePath + , oPrefix :: String + , oSuffix :: String + } + +defaults :: Options +defaults = Options { + oAll = False, oUniq = False, oDir = "", oPrefix = "", oSuffix = "" + } + +options :: [OptDescr (Options -> Options)] +options = + [ Option "a" ["all"] (NoArg (\o -> o { oAll = True })) "" + , Option "u" [] (NoArg (\o -> o { oUniq = True })) "" + , Option "d" ["dir"] (ReqArg (\x o -> o { oDir = x }) "") "" + , Option "p" ["prefix"] (ReqArg (\x o -> o { oPrefix = x }) "") "" + , Option "s" ["suffix"] (ReqArg (\x o -> o { oSuffix = x }) "") "" + ] + +parseOptions :: [String] -> IO Options +parseOptions args = + case getOpt Permute options args of + (o, _, []) -> return $ foldr id defaults o + (_, _, errs) -> ioError . userError $ concat errs + +-- | A list of display names, paths to mbox files and display colours, +-- followed by a list of options. +data MBox = MBox [(String, FilePath, String)] [String] String + deriving (Read, Show) + +instance Exec MBox where + alias (MBox _ _ a) = a + start (MBox boxes args _) cb = do + + opts <- parseOptions args + let showAll = oAll opts + prefix = oPrefix opts + suffix = oSuffix opts + uniq = oUniq opts + names = map (\(t, _, _) -> t) boxes + colors = map (\(_, _, c) -> c) boxes + extractPath (_, f, _) = expandHome $ oDir opts f + events = [CloseWrite] + + i <- initINotify + vs <- mapM (\b -> do + f <- extractPath b + exists <- doesFileExist f + n <- if exists then countMails f else return (-1) + v <- newTVarIO (f, n) + when exists $ + addWatch i events f (handleNotification v) >> return () + return v) + boxes + + changeLoop (mapM (fmap snd . readTVar) vs) $ \ns -> + let s = unwords [ showC uniq m n c | (m, n, c) <- zip3 names ns colors + , showAll || n > 0 ] + in cb (if null s then "" else prefix ++ s ++ suffix) + +showC :: Bool -> String -> Int -> String -> String +showC u m n c = + if c == "" then msg else "" ++ msg ++ "" + where msg = m ++ if not u || n > 1 then show n else "" + +countMails :: FilePath -> IO Int +countMails f = + handle ((\_ -> evaluate 0) :: SomeException -> IO Int) + (do txt <- B.readFile f + evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt) + where from = B.pack "From " + +handleNotification :: TVar (FilePath, Int) -> Event -> IO () +handleNotification v _ = do + (p, _) <- atomically $ readTVar v + n <- countMails p + atomically $ writeTVar v (p, n) diff --git a/src/Plugins/Mail.hs b/src/Plugins/Mail.hs new file mode 100644 index 0000000..38cdaae --- /dev/null +++ b/src/Plugins/Mail.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Mail +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for checking mail. +-- +----------------------------------------------------------------------------- + +module Plugins.Mail where + +import Prelude hiding (catch) +import Plugins +import Plugins.Utils (expandHome, changeLoop) + +import Control.Monad +import Control.Concurrent.STM + +import System.Directory +import System.FilePath +import System.INotify + +import Data.List (isPrefixOf) +import Data.Set (Set) +import qualified Data.Set as S + +-- | A list of mail box names and paths to maildirs. +data Mail = Mail [(String, FilePath)] + deriving (Read, Show) + +instance Exec Mail where + start (Mail ms) cb = do + vs <- mapM (const $ newTVarIO S.empty) ms + + let ts = map fst ms + rs = map (( "new") . snd) ms + ev = [Move, MoveIn, MoveOut, Create, Delete] + + ds <- mapM expandHome rs + i <- initINotify + zipWithM_ (\d v -> addWatch i ev d (handle v)) ds vs + + forM_ (zip ds vs) $ \(d, v) -> do + s <- fmap (S.fromList . filter (not . isPrefixOf ".")) + $ getDirectoryContents d + atomically $ modifyTVar v (S.union s) + + changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns -> + cb . unwords $ [m ++ ":" ++ show n + | (m, n) <- zip ts ns + , n /= 0 ] + +modifyTVar :: TVar a -> (a -> a) -> STM () +modifyTVar v f = readTVar v >>= writeTVar v . f + +handle :: TVar (Set String) -> Event -> IO () +handle v e = atomically $ modifyTVar v $ case e of + Created {} -> create + MovedIn {} -> create + Deleted {} -> delete + MovedOut {} -> delete + _ -> id + where + delete = S.delete (filePath e) + create = S.insert (filePath e) diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs new file mode 100644 index 0000000..9887d74 --- /dev/null +++ b/src/Plugins/Monitors.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Plugins.Monitors +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- The system monitor plugin for Xmobar. +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors where + +import Plugins + +import Plugins.Monitors.Common ( runM ) +import Plugins.Monitors.Weather +import Plugins.Monitors.Net +import Plugins.Monitors.Mem +import Plugins.Monitors.Swap +import Plugins.Monitors.Cpu +import Plugins.Monitors.MultiCpu +import Plugins.Monitors.Batt +import Plugins.Monitors.Thermal +import Plugins.Monitors.CpuFreq +import Plugins.Monitors.CoreTemp +import Plugins.Monitors.Disk +import Plugins.Monitors.Top +import Plugins.Monitors.Uptime +#ifdef IWLIB +import Plugins.Monitors.Wireless +#endif +#ifdef LIBMPD +import Plugins.Monitors.MPD +#endif + +data Monitors = Weather Station Args Rate + | Network Interface Args Rate + | Memory Args Rate + | Swap Args Rate + | Cpu Args Rate + | MultiCpu Args Rate + | Battery Args Rate + | BatteryP [String] Args Rate + | DiskU DiskSpec Args Rate + | DiskIO DiskSpec Args Rate + | Thermal Zone Args Rate + | CpuFreq Args Rate + | CoreTemp Args Rate + | TopProc Args Rate + | TopMem Args Rate + | Uptime Args Rate +#ifdef IWLIB + | Wireless Interface Args Rate +#endif +#ifdef LIBMPD + | MPD Args Rate +#endif + deriving (Show,Read,Eq) + +type Args = [String] +type Program = String +type Alias = String +type Station = String +type Zone = String +type Interface = String +type Rate = Int +type DiskSpec = [(String, String)] + +instance Exec Monitors where + alias (Weather s _ _) = s + alias (Network i _ _) = i + alias (Thermal z _ _) = z + alias (Memory _ _) = "memory" + alias (Swap _ _) = "swap" + alias (Cpu _ _) = "cpu" + alias (MultiCpu _ _) = "multicpu" + alias (Battery _ _) = "battery" + alias (BatteryP _ _ _)= "battery" + alias (CpuFreq _ _) = "cpufreq" + alias (TopProc _ _) = "top" + alias (TopMem _ _) = "topmem" + alias (CoreTemp _ _) = "coretemp" + alias (DiskU _ _ _) = "disku" + alias (DiskIO _ _ _) = "diskio" + alias (Uptime _ _) = "uptime" +#ifdef IWLIB + alias (Wireless i _ _) = i ++ "wi" +#endif +#ifdef LIBMPD + alias (MPD _ _) = "mpd" +#endif + start (Weather s a r) = runM (a ++ [s]) weatherConfig runWeather r + start (Network i a r) = runM (a ++ [i]) netConfig runNet r + start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r + start (Memory a r) = runM a memConfig runMem r + start (Swap a r) = runM a swapConfig runSwap r + start (Cpu a r) = runM a cpuConfig runCpu r + start (MultiCpu a r) = runM a multiCpuConfig runMultiCpu r + start (Battery a r) = runM a battConfig runBatt r + start (BatteryP s a r) = runM a battConfig (runBatt' s) r + start (CpuFreq a r) = runM a cpuFreqConfig runCpuFreq r + start (CoreTemp a r) = runM a coreTempConfig runCoreTemp r + start (DiskU s a r) = runM a diskUConfig (runDiskU s) r + start (DiskIO s a r) = runM a diskIOConfig (runDiskIO s) r + start (TopMem a r) = runM a topMemConfig runTopMem r + start (Uptime a r) = runM a uptimeConfig runUptime r + start (TopProc a r) = startTop a r +#ifdef IWLIB + start (Wireless i a r) = runM (a ++ [i]) wirelessConfig runWireless r +#endif +#ifdef LIBMPD + start (MPD a r) = runM a mpdConfig runMPD r +#endif diff --git a/src/Plugins/Monitors/Batt.hs b/src/Plugins/Monitors/Batt.hs new file mode 100644 index 0000000..11b2d6c --- /dev/null +++ b/src/Plugins/Monitors/Batt.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Batt +-- Copyright : (c) Andrea Rossato, 2010 Petr Rockai, 2010 Jose A Ortega +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A battery monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where + +import qualified Data.ByteString.Lazy.Char8 as B +import Plugins.Monitors.Common +import System.Posix.Files (fileExist) +import System.Console.GetOpt + +data BattOpts = BattOpts + { onString :: String + , offString :: String + , posColor :: Maybe String + , lowWColor :: Maybe String + , mediumWColor :: Maybe String + , highWColor :: Maybe String + , lowThreshold :: Float + , highThreshold :: Float + } + +defaultOpts :: BattOpts +defaultOpts = BattOpts + { onString = "On" + , offString = "Off" + , posColor = Nothing + , lowWColor = Nothing + , mediumWColor = Nothing + , highWColor = Nothing + , lowThreshold = -12 + , highThreshold = -10 + } + +options :: [OptDescr (BattOpts -> BattOpts)] +options = + [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" + , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") "" + , Option "p" ["positive"] (ReqArg (\x o -> o { posColor = Just x }) "") "" + , Option "l" ["low"] (ReqArg (\x o -> o { lowWColor = Just x }) "") "" + , Option "m" ["medium"] (ReqArg (\x o -> o { mediumWColor = Just x }) "") "" + , Option "h" ["high"] (ReqArg (\x o -> o { highWColor = Just x }) "") "" + , Option "L" ["lowt"] (ReqArg (\x o -> o { lowThreshold = read x }) "") "" + , Option "H" ["hight"] (ReqArg (\x o -> o { highThreshold = read x }) "") "" + ] + +parseOpts :: [String] -> IO BattOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +data Result = Result Float Float Float String | NA + +base :: String +base = "/sys/class/power_supply" + +battConfig :: IO MConfig +battConfig = mkMConfig + "Batt: , % / " -- template + ["leftbar", "left", "acstatus", "timeleft", "watts"] -- replacements + +data Files = Files + { f_full :: String + , f_now :: String + , f_voltage :: String + , f_current :: String + } | NoFiles + +data Battery = Battery + { full :: Float + , now :: Float + , voltage :: Float + , current :: Float + } + +batteryFiles :: String -> IO Files +batteryFiles bat = + do is_charge <- fileExist $ prefix ++ "/charge_now" + is_energy <- fileExist $ prefix ++ "/energy_now" + return $ case (is_charge, is_energy) of + (True, _) -> files "/charge" + (_, True) -> files "/energy" + _ -> NoFiles + where prefix = base ++ "/" ++ bat + files ch = Files { f_full = prefix ++ ch ++ "_full" + , f_now = prefix ++ ch ++ "_now" + , f_current = prefix ++ "/current_now" + , f_voltage = prefix ++ "/voltage_now" } + +haveAc :: IO (Maybe Bool) +haveAc = do know <- fileExist $ base ++ "/AC/online" + if know + then do s <- B.unpack `fmap` catRead (base ++ "/AC/online") + return $ Just $ s == "1\n" + else return Nothing + +readBattery :: Files -> IO Battery +readBattery NoFiles = return $ Battery 0 0 0 0 +readBattery files = + do a <- grab $ f_full files -- microwatthours + b <- grab $ f_now files + c <- grab $ f_voltage files -- microvolts + d <- grab $ f_current files -- microwatts (huh!) + return $ Battery (3600 * a / 1000000) -- wattseconds + (3600 * b / 1000000) -- wattseconds + (c / 1000000) -- volts + (d / c) -- amperes + where grab = fmap (read . B.unpack) . catRead + +readBatteries :: BattOpts -> [Files] -> IO Result +readBatteries opts bfs = + do bats <- mapM readBattery (take 3 bfs) + ac' <- haveAc + let ac = (ac' == Just True) + sign = if ac then 1 else -1 + left = sum (map now bats) / sum (map full bats) + watts = sign * sum (map voltage bats) * sum (map current bats) + time = if watts == 0 then 0 else sum $ map time' bats -- negate sign + time' b = (if ac then full b - now b else now b) / (sign * watts) + acstr = case ac' of + Nothing -> "?" + Just True -> onString opts + Just False -> offString opts + return $ if isNaN left then NA else Result left watts time acstr + +runBatt :: [String] -> Monitor String +runBatt = runBatt' ["BAT0","BAT1","BAT2"] + +runBatt' :: [String] -> [String] -> Monitor String +runBatt' bfs args = do + opts <- io $ parseOpts args + c <- io $ readBatteries opts =<< mapM batteryFiles bfs + case c of + Result x w t s -> + do l <- fmtPercent x + parseTemplate (l ++ s:[fmtTime $ floor t, fmtWatts w opts]) + NA -> return "N/A" + where fmtPercent :: Float -> Monitor [String] + fmtPercent x = do + p <- showPercentWithColors x + b <- showPercentBar (100 * x) x + return [b, p] + fmtWatts x o = color x o $ showDigits 1 x ++ "W" + fmtTime :: Integer -> String + fmtTime x = hours ++ ":" ++ if length minutes == 2 + then minutes else '0' : minutes + where hours = show (x `div` 3600) + minutes = show ((x `mod` 3600) `div` 60) + maybeColor Nothing _ = "" + maybeColor (Just c) str = "" ++ str ++ "" + color x o | x >= 0 = maybeColor (posColor o) + | x >= highThreshold o = maybeColor (highWColor o) + | x >= lowThreshold o = maybeColor (mediumWColor o) + | otherwise = maybeColor (lowWColor o) diff --git a/src/Plugins/Monitors/Common.hs b/src/Plugins/Monitors/Common.hs new file mode 100644 index 0000000..cc1a6a7 --- /dev/null +++ b/src/Plugins/Monitors/Common.hs @@ -0,0 +1,446 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Common +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- Utilities for creating monitors for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Common ( + -- * Monitors + -- $monitor + Monitor + , MConfig (..) + , Opts (..) + , setConfigValue + , getConfigValue + , mkMConfig + , runM + , io + -- * Parsers + -- $parsers + , runP + , skipRestOfLine + , getNumbers + , getNumbersAsString + , getAllBut + , getAfterString + , skipTillString + , parseTemplate + -- ** String Manipulation + -- $strings + , padString + , showWithPadding + , showWithColors + , showWithColors' + , showPercentWithColors + , showPercentsWithColors + , showPercentBar + , showLogBar + , showWithUnits + , takeDigits + , showDigits + , floatToPercent + , parseFloat + , parseInt + , stringParser + -- * Threaded Actions + -- $thread + , doActionTwiceWithDelay + , catRead + ) where + + +import Control.Concurrent +import Control.Monad.Reader +import qualified Data.ByteString.Lazy.Char8 as B +import Data.IORef +import qualified Data.Map as Map +import Data.List +import Numeric +import Text.ParserCombinators.Parsec +import System.Console.GetOpt +import Control.Exception (SomeException,handle) +import System.Process (readProcess) + +import Plugins +-- $monitor + +type Monitor a = ReaderT MConfig IO a + +data MConfig = + MC { normalColor :: IORef (Maybe String) + , low :: IORef Int + , lowColor :: IORef (Maybe String) + , high :: IORef Int + , highColor :: IORef (Maybe String) + , template :: IORef String + , export :: IORef [String] + , ppad :: IORef Int + , minWidth :: IORef Int + , maxWidth :: IORef Int + , padChars :: IORef String + , padRight :: IORef Bool + , barBack :: IORef String + , barFore :: IORef String + , barWidth :: IORef Int + , useSuffix :: IORef Bool + } + +-- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' +type Selector a = MConfig -> IORef a + +sel :: Selector a -> Monitor a +sel s = + do hs <- ask + liftIO $ readIORef (s hs) + +mods :: Selector a -> (a -> a) -> Monitor () +mods s m = + do v <- ask + io $ modifyIORef (s v) m + +setConfigValue :: a -> Selector a -> Monitor () +setConfigValue v s = + mods s (\_ -> v) + +getConfigValue :: Selector a -> Monitor a +getConfigValue = sel + +mkMConfig :: String + -> [String] + -> IO MConfig +mkMConfig tmpl exprts = + do lc <- newIORef Nothing + l <- newIORef 33 + nc <- newIORef Nothing + h <- newIORef 66 + hc <- newIORef Nothing + t <- newIORef tmpl + e <- newIORef exprts + p <- newIORef 0 + mn <- newIORef 0 + mx <- newIORef 0 + pc <- newIORef " " + pr <- newIORef False + bb <- newIORef ":" + bf <- newIORef "#" + bw <- newIORef 10 + up <- newIORef False + return $ MC nc l lc h hc t e p mn mx pc pr bb bf bw up + +data Opts = HighColor String + | NormalColor String + | LowColor String + | Low String + | High String + | Template String + | PercentPad String + | MinWidth String + | MaxWidth String + | Width String + | PadChars String + | PadAlign String + | BarBack String + | BarFore String + | BarWidth String + | UseSuffix String + +options :: [OptDescr Opts] +options = + [ Option "H" ["High"] (ReqArg High "number" ) "The high threshold" + , Option "L" ["Low"] (ReqArg Low "number" ) "The low threshold" + , Option "h" ["high"] (ReqArg HighColor "color number" ) "Color for the high threshold: ex \"#FF0000\"" + , Option "n" ["normal"] (ReqArg NormalColor "color number" ) "Color for the normal threshold: ex \"#00FF00\"" + , Option "l" ["low"] (ReqArg LowColor "color number" ) "Color for the low threshold: ex \"#0000FF\"" + , Option "t" ["template"] (ReqArg Template "output template" ) "Output template." + , Option "S" ["suffix"] (ReqArg UseSuffix "True/False" ) "Use % to display percents or other suffixes." + , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width." + , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width" ) "Minimum field width" + , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width" ) "Maximum field width" + , Option "w" ["width"] (ReqArg Width "fixed width" ) "Fixed field width" + , Option "c" ["padchars"] (ReqArg PadChars "padding chars" ) "Characters to use for padding" + , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right" + , Option "b" ["bback"] (ReqArg BarBack "bar background" ) "Characters used to draw bar backgrounds" + , Option "f" ["bfore"] (ReqArg BarFore "bar foreground" ) "Characters used to draw bar foregrounds" + , Option "W" ["bwidth"] (ReqArg BarWidth "bar width" ) "Bar width" + ] + +doArgs :: [String] + -> ([String] -> Monitor String) + -> Monitor String +doArgs args action = + case getOpt Permute options args of + (o, n, []) -> do doConfigOptions o + action n + (_, _, errs) -> return (concat errs) + +doConfigOptions :: [Opts] -> Monitor () +doConfigOptions [] = io $ return () +doConfigOptions (o:oo) = + do let next = doConfigOptions oo + nz s = let x = read s in max 0 x + bool = (`elem` ["True", "true", "Yes", "yes", "On", "on"]) + (case o of + High h -> setConfigValue (read h) high + Low l -> setConfigValue (read l) low + HighColor c -> setConfigValue (Just c) highColor + NormalColor c -> setConfigValue (Just c) normalColor + LowColor c -> setConfigValue (Just c) lowColor + Template t -> setConfigValue t template + PercentPad p -> setConfigValue (nz p) ppad + MinWidth w -> setConfigValue (nz w) minWidth + MaxWidth w -> setConfigValue (nz w) maxWidth + Width w -> setConfigValue (nz w) minWidth >> + setConfigValue (nz w) maxWidth + PadChars s -> setConfigValue s padChars + PadAlign a -> setConfigValue ("r" `isPrefixOf` a) padRight + BarBack s -> setConfigValue s barBack + BarFore s -> setConfigValue s barFore + BarWidth w -> setConfigValue (nz w) barWidth + UseSuffix u -> setConfigValue (bool u) useSuffix) >> next + +runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int + -> (String -> IO ()) -> IO () +runM args conf action r cb = handle (cb . showException) loop + where ac = doArgs args action + loop = conf >>= runReaderT ac >>= cb >> tenthSeconds r >> loop + +showException :: SomeException -> String +showException = ("error: "++) . show . flip asTypeOf undefined + +io :: IO a -> Monitor a +io = liftIO + +-- $parsers + +runP :: Parser [a] -> String -> IO [a] +runP p i = + case parse p "" i of + Left _ -> return [] + Right x -> return x + +getAllBut :: String -> Parser String +getAllBut s = + manyTill (noneOf s) (char $ head s) + +getNumbers :: Parser Float +getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n + +getNumbersAsString :: Parser String +getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n + +skipRestOfLine :: Parser Char +skipRestOfLine = + do many $ noneOf "\n\r" + newline + +getAfterString :: String -> Parser String +getAfterString s = + do { try $ manyTill skipRestOfLine $ string s + ; manyTill anyChar newline + } <|> return "" + +skipTillString :: String -> Parser String +skipTillString s = + manyTill skipRestOfLine $ string s + +-- | Parses the output template string +templateStringParser :: Parser (String,String,String) +templateStringParser = + do { s <- nonPlaceHolder + ; com <- templateCommandParser + ; ss <- nonPlaceHolder + ; return (s, com, ss) + } + where + nonPlaceHolder = liftM concat . many $ + many1 (noneOf "<") <|> colorSpec + +-- | Recognizes color specification and returns it unchanged +colorSpec :: Parser String +colorSpec = try (string "") <|> try ( + do string " char ',' <|> char '#') + char '>' + return $ "") + +-- | Parses the command part of the template string +templateCommandParser :: Parser String +templateCommandParser = + do { char '<' + ; com <- many $ noneOf ">" + ; char '>' + ; return com + } + +-- | Combines the template parsers +templateParser :: Parser [(String,String,String)] +templateParser = many templateStringParser --"%") + +-- | Takes a list of strings that represent the values of the exported +-- keys. The strings are joined with the exported keys to form a map +-- to be combined with 'combine' to the parsed template. Returns the +-- final output of the monitor. +parseTemplate :: [String] -> Monitor String +parseTemplate l = + do t <- getConfigValue template + s <- io $ runP templateParser t + e <- getConfigValue export + let m = Map.fromList . zip e $ l + return $ combine m s + +-- | Given a finite "Map" and a parsed templatet produces the +-- | resulting output string. +combine :: Map.Map String String -> [(String, String, String)] -> String +combine _ [] = [] +combine m ((s,ts,ss):xs) = + s ++ str ++ ss ++ combine m xs + where str = Map.findWithDefault err ts m + err = "<" ++ ts ++ " not found!>" + +-- $strings + +type Pos = (Int, Int) + +takeDigits :: Int -> Float -> Float +takeDigits d n = + fromIntegral (round (n * fact) :: Int) / fact + where fact = 10 ^ d + +showDigits :: (RealFloat a) => Int -> a -> String +showDigits d n = showFFloat (Just d) n "" + +showWithUnits :: Int -> Int -> Float -> String +showWithUnits d n x + | x < 0 = '-' : showWithUnits d n (-x) + | n > 3 || x < 10^(d + 1) = show (round x :: Int) ++ units n + | x <= 1024 = showDigits d (x/1024) ++ units (n+1) + | otherwise = showWithUnits d (n+1) (x/1024) + where units = (!!) ["B", "K", "M", "G", "T"] + +padString :: Int -> Int -> String -> Bool -> String -> String +padString mnw mxw pad pr s = + let len = length s + rmin = if mnw <= 0 then 1 else mnw + rmax = if mxw <= 0 then max len rmin else mxw + (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin) + rlen = min (max rmn len) rmx + in if rlen < len then + take rlen s + else let ps = take (rlen - len) (cycle pad) + in if pr then s ++ ps else ps ++ s + +parseFloat :: String -> Float +parseFloat s = case readFloat s of + (v, _):_ -> v + _ -> 0 + +parseInt :: String -> Int +parseInt s = case readDec s of + (v, _):_ -> v + _ -> 0 + +floatToPercent :: Float -> Monitor String +floatToPercent n = + do pad <- getConfigValue ppad + pc <- getConfigValue padChars + pr <- getConfigValue padRight + up <- getConfigValue useSuffix + let p = showDigits 0 (n * 100) + ps = if up then "%" else "" + return $ padString pad pad pc pr p ++ ps + +stringParser :: Pos -> B.ByteString -> String +stringParser (x,y) = + B.unpack . li x . B.words . li y . B.lines + where li i l | length l > i = l !! i + | otherwise = B.empty + +setColor :: String -> Selector (Maybe String) -> Monitor String +setColor str s = + do a <- getConfigValue s + case a of + Nothing -> return str + Just c -> return $ + "" ++ str ++ "" + +showWithPadding :: String -> Monitor String +showWithPadding s = + do mn <- getConfigValue minWidth + mx <- getConfigValue maxWidth + p <- getConfigValue padChars + pr <- getConfigValue padRight + return $ padString mn mx p pr s + +colorizeString :: (Num a, Ord a) => a -> String -> Monitor String +colorizeString x s = do + h <- getConfigValue high + l <- getConfigValue low + let col = setColor s + [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low + head $ [col highColor | x > hh ] ++ + [col normalColor | x > ll ] ++ + [col lowColor | True] + +showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String +showWithColors f x = showWithPadding (f x) >>= colorizeString x + +showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String +showWithColors' str = showWithColors (const str) + +showPercentsWithColors :: [Float] -> Monitor [String] +showPercentsWithColors fs = + do fstrs <- mapM floatToPercent fs + zipWithM (showWithColors . const) fstrs (map (*100) fs) + +showPercentWithColors :: Float -> Monitor String +showPercentWithColors f = liftM head $ showPercentsWithColors [f] + +showPercentBar :: Float -> Float -> Monitor String +showPercentBar v x = do + bb <- getConfigValue barBack + bf <- getConfigValue barFore + bw <- getConfigValue barWidth + let len = min bw $ round (fromIntegral bw * x) + s <- colorizeString v (take len $ cycle bf) + return $ s ++ take (bw - len) (cycle bb) + +showLogBar :: Float -> Float -> Monitor String +showLogBar f v = do + h <- fromIntegral `fmap` getConfigValue high + l <- fromIntegral `fmap` getConfigValue low + bw <- fromIntegral `fmap` getConfigValue barWidth + let [ll, hh] = sort [l, h] + choose x | x == 0.0 = 0 + | x <= ll = 1 / bw + | otherwise = f + logBase 2 (x / hh) / bw + showPercentBar v $ choose v + +-- $threads + +doActionTwiceWithDelay :: Int -> IO [a] -> IO ([a], [a]) +doActionTwiceWithDelay delay action = + do v1 <- newMVar [] + forkIO $! getData action v1 0 + v2 <- newMVar [] + forkIO $! getData action v2 delay + threadDelay (delay `div` 3 * 4) + a <- readMVar v1 + b <- readMVar v2 + return (a,b) + +getData :: IO a -> MVar a -> Int -> IO () +getData action var d = + do threadDelay d + s <- action + modifyMVar_ var (\_ -> return $! s) + +catRead :: FilePath -> IO B.ByteString +catRead file = B.pack `fmap` readProcess "/bin/cat" [file] "" diff --git a/src/Plugins/Monitors/CoreCommon.hs b/src/Plugins/Monitors/CoreCommon.hs new file mode 100644 index 0000000..80e7700 --- /dev/null +++ b/src/Plugins/Monitors/CoreCommon.hs @@ -0,0 +1,59 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CoreCommon +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek +-- Stability : unstable +-- Portability : unportable +-- +-- The common part for cpu core monitors (e.g. cpufreq, coretemp) +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.CoreCommon where + +import Plugins.Monitors.Common +import System.Posix.Files (fileExist) +import System.IO (withFile, IOMode(ReadMode), hGetLine) +import System.Directory +import Data.Char (isDigit) +import Data.List (isPrefixOf) + +-- | +-- Function checks the existence of first file specified by pattern and if the +-- file doesn't exists failure message is shown, otherwise the data retrieval +-- is performed. +checkedDataRetrieval :: (Num a, Ord a, Show a) => + String -> String -> String -> String -> (Double -> a) + -> (a -> String) -> Monitor String +checkedDataRetrieval failureMessage dir file pattern trans fmt = do + exists <- io $ fileExist $ concat [dir, "/", pattern, "0/", file] + case exists of + False -> return failureMessage + True -> retrieveData dir file pattern trans fmt + +-- | +-- Function retrieves data from files in directory dir specified by +-- pattern. String values are converted to double and 'trans' applied +-- to each one. Final array is processed by template parser function +-- and returned as monitor string. +retrieveData :: (Num a, Ord a, Show a) => + String -> String -> String -> (Double -> a) -> (a -> String) -> + Monitor String +retrieveData dir file pattern trans fmt = do + count <- io $ dirCount dir pattern + contents <- io $ mapM getGuts $ files count + values <- mapM (showWithColors fmt) $ map conversion contents + parseTemplate values + where + getGuts f = withFile f ReadMode hGetLine + dirCount path str = getDirectoryContents path + >>= return . length + . filter (\s -> str `isPrefixOf` s + && isDigit (last s)) + files count = map (\i -> concat [dir, "/", pattern, show i, "/", file]) + [0 .. count - 1] + conversion = trans . (read :: String -> Double) + diff --git a/src/Plugins/Monitors/CoreTemp.hs b/src/Plugins/Monitors/CoreTemp.hs new file mode 100644 index 0000000..a24b284 --- /dev/null +++ b/src/Plugins/Monitors/CoreTemp.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CoreTemp +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek +-- Stability : unstable +-- Portability : unportable +-- +-- A core temperature monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.CoreTemp where + +import Plugins.Monitors.Common +import Plugins.Monitors.CoreCommon + +-- | +-- Core temperature default configuration. Default template contains only one +-- core temperature, user should specify custom template in order to get more +-- core frequencies. +coreTempConfig :: IO MConfig +coreTempConfig = mkMConfig + "Temp: C" -- template + (zipWith (++) (repeat "core") (map show [0 :: Int ..])) -- available + -- replacements + +-- | +-- Function retrieves monitor string holding the core temperature +-- (or temperatures) +runCoreTemp :: [String] -> Monitor String +runCoreTemp _ = do + let dir = "/sys/bus/platform/devices" + file = "temp1_input" + pattern = "coretemp." + divisor = 1e3 :: Double + failureMessage = "CoreTemp: N/A" + checkedDataRetrieval failureMessage dir file pattern (/divisor) show + diff --git a/src/Plugins/Monitors/Cpu.hs b/src/Plugins/Monitors/Cpu.hs new file mode 100644 index 0000000..ab89246 --- /dev/null +++ b/src/Plugins/Monitors/Cpu.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Cpu +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A cpu monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Cpu where + +import Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B + +cpuConfig :: IO MConfig +cpuConfig = mkMConfig + "Cpu: %" + ["bar","total","user","nice","system","idle"] + +cpuData :: IO [Float] +cpuData = do s <- B.readFile "/proc/stat" + return $ cpuParser s + +cpuParser :: B.ByteString -> [Float] +cpuParser = + map (read . B.unpack) . tail . B.words . head . B.lines + +parseCPU :: IO [Float] +parseCPU = + do (a,b) <- doActionTwiceWithDelay 750000 cpuData + let dif = zipWith (-) b a + tot = foldr (+) 0 dif + percent = map (/ tot) dif + return percent + +formatCpu :: [Float] -> Monitor [String] +formatCpu [] = return $ repeat "" +formatCpu xs = do + let t = foldr (+) 0 $ take 3 xs + b <- showPercentBar (100 * t) t + ps <- showPercentsWithColors (t:xs) + return (b:ps) + +runCpu :: [String] -> Monitor String +runCpu _ = + do c <- io parseCPU + l <- formatCpu c + parseTemplate l diff --git a/src/Plugins/Monitors/CpuFreq.hs b/src/Plugins/Monitors/CpuFreq.hs new file mode 100644 index 0000000..4f01922 --- /dev/null +++ b/src/Plugins/Monitors/CpuFreq.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CpuFreq +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek +-- Stability : unstable +-- Portability : unportable +-- +-- A cpu frequency monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.CpuFreq where + +import Plugins.Monitors.Common +import Plugins.Monitors.CoreCommon + +-- | +-- Cpu frequency default configuration. Default template contains only one +-- core frequency, user should specify custom template in order to get more +-- cpu frequencies. +cpuFreqConfig :: IO MConfig +cpuFreqConfig = mkMConfig + "Freq: " -- template + (zipWith (++) (repeat "cpu") (map show [0 :: Int ..])) -- available + -- replacements + +-- | +-- Function retrieves monitor string holding the cpu frequency (or +-- frequencies) +runCpuFreq :: [String] -> Monitor String +runCpuFreq _ = do + let dir = "/sys/devices/system/cpu" + file = "cpufreq/scaling_cur_freq" + pattern = "cpu" + divisor = 1e6 :: Double + failureMessage = "CpuFreq: N/A" + fmt x | x < 1 = show (round (x * 1000) :: Integer) ++ "MHz" + | otherwise = showDigits 1 x ++ "GHz" + checkedDataRetrieval failureMessage dir file pattern (/divisor) fmt + diff --git a/src/Plugins/Monitors/Disk.hs b/src/Plugins/Monitors/Disk.hs new file mode 100644 index 0000000..f3a7a2a --- /dev/null +++ b/src/Plugins/Monitors/Disk.hs @@ -0,0 +1,137 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Disk +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- Disk usage and throughput monitors for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Disk ( diskUConfig, runDiskU + , diskIOConfig, runDiskIO + ) where + +import Plugins.Monitors.Common +import StatFS + +import Control.Monad (zipWithM) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (isPrefixOf, find, intercalate) + +diskIOConfig :: IO MConfig +diskIOConfig = mkMConfig "" ["total", "read", "write", + "totalbar", "readbar", "writebar"] + +diskUConfig :: IO MConfig +diskUConfig = mkMConfig "" + ["size", "free", "used", "freep", "usedp", "freebar", "usedbar"] + +type DevName = String +type Path = String + +mountedDevices :: [String] -> IO [(DevName, Path)] +mountedDevices req = do + s <- B.readFile "/etc/mtab" + return (parse s) + where + parse = map undev . filter isDev . map (firstTwo . B.words) . B.lines + firstTwo (a:b:_) = (B.unpack a, B.unpack b) + firstTwo _ = ("", "") + isDev (d, p) = "/dev/" `isPrefixOf` d && + (p `elem` req || drop 5 d `elem` req) + undev (d, f) = (drop 5 d, f) + +diskData :: IO [(DevName, [Float])] +diskData = do + s <- B.readFile "/proc/diskstats" + let extract ws = (head ws, map read (tail ws)) + return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s) + +mountedData :: [DevName] -> IO [(DevName, [Float])] +mountedData devs = do + (dt, dt') <- doActionTwiceWithDelay 750000 diskData + return $ map (parseDev (zipWith diff dt' dt)) devs + where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys) + +parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float]) +parseDev dat dev = + case find ((==dev) . fst) dat of + Nothing -> (dev, [0, 0, 0]) + Just (_, xs) -> + let rSp = speed (xs !! 2) (xs !! 3) + wSp = speed (xs !! 6) (xs !! 7) + sp = speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7) + speed x t = if t == 0 then 0 else 500 * x / t + dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0] + in (dev, dat') + +fsStats :: String -> IO [Integer] +fsStats path = do + stats <- getFileSystemStats path + case stats of + Nothing -> return [-1, -1, -1] + Just f -> let tot = fsStatByteCount f + free = fsStatBytesAvailable f + used = fsStatBytesUsed f + in return [tot, free, used] + +speedToStr :: Float -> String +speedToStr = showWithUnits 2 1 + +sizeToStr :: Integer -> String +sizeToStr = showWithUnits 3 0 . fromIntegral + +findTempl :: DevName -> Path -> [(String, String)] -> String +findTempl dev path disks = + case find devOrPath disks of + Just (_, t) -> t + Nothing -> "" + where devOrPath (d, _) = d == dev || d == path + +devTemplates :: [(String, String)] + -> [(DevName, Path)] + -> [(DevName, [Float])] + -> [(String, [Float])] +devTemplates disks mounted dat = + map (\(d, p) -> (findTempl d p disks, findData d)) mounted + where findData dev = case find ((==dev) . fst) dat of + Nothing -> [0, 0, 0] + Just (_, xs) -> xs + +runDiskIO' :: (String, [Float]) -> Monitor String +runDiskIO' (tmp, xs) = do + s <- mapM (showWithColors speedToStr) xs + b <- mapM (showLogBar 0.8) xs + setConfigValue tmp template + parseTemplate $ s ++ b + +runDiskIO :: [(String, String)] -> [String] -> Monitor String +runDiskIO disks _ = do + mounted <- io $ mountedDevices (map fst disks) + dat <- io $ mountedData (map fst mounted) + strs <- mapM runDiskIO' $ devTemplates disks mounted dat + return $ intercalate " " strs + +runDiskU' :: String -> String -> Monitor String +runDiskU' tmp path = do + setConfigValue tmp template + fstats <- io $ fsStats path + let strs = map sizeToStr fstats + freep = (fstats !! 1) * 100 `div` head fstats + fr = fromIntegral freep / 100 + s <- zipWithM showWithColors' strs [100, freep, 100 - freep] + sp <- showPercentsWithColors [fr, 1 - fr] + fb <- showPercentBar (fromIntegral freep) fr + ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr) + parseTemplate $ s ++ sp ++ [fb, ub] + +runDiskU :: [(String, String)] -> [String] -> Monitor String +runDiskU disks _ = do + devs <- io $ mountedDevices (map fst disks) + strs <- mapM (\(d, p) -> runDiskU' (findTempl d p disks) p) devs + return $ intercalate " " strs diff --git a/src/Plugins/Monitors/MPD.hs b/src/Plugins/Monitors/MPD.hs new file mode 100644 index 0000000..daf0ed4 --- /dev/null +++ b/src/Plugins/Monitors/MPD.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.MPD +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- MPD status and song +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.MPD ( mpdConfig, runMPD ) where + +import Plugins.Monitors.Common +import System.Console.GetOpt +import qualified Network.MPD as M + +mpdConfig :: IO MConfig +mpdConfig = mkMConfig "MPD: " + [ "bar", "state", "statei", "volume", "length" + , "lapsed", "remaining", "plength", "ppos", "file" + , "name", "artist", "composer", "performer" + , "album", "title", "track", "genre" + ] + +data MOpts = MOpts + { mPlaying :: String + , mStopped :: String + , mPaused :: String + , mHost :: String + , mPort :: Integer + , mPassword :: String + } + +defaultOpts :: MOpts +defaultOpts = MOpts + { mPlaying = ">>" + , mStopped = "><" + , mPaused = "||" + , mHost = "127.0.0.1" + , mPort = 6600 + , mPassword = "" + } + +options :: [OptDescr (MOpts -> MOpts)] +options = + [ Option "P" ["playing"] (ReqArg (\x o -> o { mPlaying = x }) "") "" + , Option "S" ["stopped"] (ReqArg (\x o -> o { mStopped = x }) "") "" + , Option "Z" ["paused"] (ReqArg (\x o -> o { mPaused = x }) "") "" + , Option "h" ["host"] (ReqArg (\x o -> o { mHost = x }) "") "" + , Option "p" ["port"] (ReqArg (\x o -> o { mPort = read x }) "") "" + , Option "x" ["password"] (ReqArg (\x o -> o { mPassword = x }) "") "" + ] + +runMPD :: [String] -> Monitor String +runMPD args = do + opts <- io $ mopts args + let mpd = M.withMPDEx (mHost opts) (mPort opts) (mPassword opts) + status <- io $ mpd M.status + song <- io $ mpd M.currentSong + s <- parseMPD status song opts + parseTemplate s + +mopts :: [String] -> IO MOpts +mopts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +parseMPD :: M.Response M.Status -> M.Response (Maybe M.Song) -> MOpts + -> Monitor [String] +parseMPD (Left e) _ _ = return $ show e:repeat "" +parseMPD (Right st) song opts = do + songData <- parseSong song + bar <- showPercentBar (100 * b) b + return $ [bar, ss, si, vol, len, lap, remain, plen, ppos] ++ songData + where s = M.stState st + ss = show s + si = stateGlyph s opts + vol = int2str $ M.stVolume st + (p, t) = M.stTime st + [lap, len, remain] = map showTime [floor p, t, max 0 (t - floor p)] + b = if t > 0 then realToFrac $ p / fromIntegral t else 0 + plen = int2str $ M.stPlaylistLength st + ppos = maybe "" (int2str . (+1)) $ M.stSongPos st + +stateGlyph :: M.State -> MOpts -> String +stateGlyph s o = + case s of + M.Playing -> mPlaying o + M.Paused -> mPaused o + M.Stopped -> mStopped o + +parseSong :: M.Response (Maybe M.Song) -> Monitor [String] +parseSong (Left _) = return $ repeat "" +parseSong (Right Nothing) = return $ repeat "" +parseSong (Right (Just s)) = + let join [] = "" + join (x:xs) = foldl (\a o -> a ++ ", " ++ o) x xs + str sel = maybe "" join (M.sgGet sel s) + sels = [ M.Name, M.Artist, M.Composer, M.Performer + , M.Album, M.Title, M.Track, M.Genre ] + fields = M.sgFilePath s : map str sels + in mapM showWithPadding fields + +showTime :: Integer -> String +showTime t = int2str minutes ++ ":" ++ int2str seconds + where minutes = t `div` 60 + seconds = t `mod` 60 + +int2str :: (Num a, Ord a) => a -> String +int2str x = if x < 10 then '0':sx else sx where sx = show x diff --git a/src/Plugins/Monitors/Mem.hs b/src/Plugins/Monitors/Mem.hs new file mode 100644 index 0000000..5c55ee2 --- /dev/null +++ b/src/Plugins/Monitors/Mem.hs @@ -0,0 +1,59 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Mem +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A memory monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where + +import Plugins.Monitors.Common + +memConfig :: IO MConfig +memConfig = mkMConfig + "Mem: % (M)" -- template + ["usedbar", "freebar", "usedratio", "total", + "free", "buffer", "cache", "rest", "used"] -- available replacements + +fileMEM :: IO String +fileMEM = readFile "/proc/meminfo" + +parseMEM :: IO [Float] +parseMEM = + do file <- fileMEM + let content = map words $ take 4 $ lines file + [total, free, buffer, cache] = map (\line -> (read $ line !! 1 :: Float) / 1024) content + rest = free + buffer + cache + used = total - rest + usedratio = used / total + return [usedratio, total, free, buffer, cache, rest, used] + +totalMem :: IO Float +totalMem = fmap ((*1024) . (!!1)) parseMEM + +usedMem :: IO Float +usedMem = fmap ((*1024) . (!!6)) parseMEM + +formatMem :: [Float] -> Monitor [String] +formatMem (r:xs) = + do let f = showDigits 0 + rr = 100 * r + ub <- showPercentBar rr r + fb <- showPercentBar (100 - rr) (1 - r) + rs <- showPercentWithColors r + s <- mapM (showWithColors f) xs + return (ub:fb:rs:s) +formatMem _ = return $ replicate 9 "N/A" + +runMem :: [String] -> Monitor String +runMem _ = + do m <- io parseMEM + l <- formatMem m + parseTemplate l diff --git a/src/Plugins/Monitors/MultiCpu.hs b/src/Plugins/Monitors/MultiCpu.hs new file mode 100644 index 0000000..535196a --- /dev/null +++ b/src/Plugins/Monitors/MultiCpu.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.MultiCpu +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega +-- Stability : unstable +-- Portability : unportable +-- +-- A multi-cpu monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.MultiCpu(multiCpuConfig, runMultiCpu) where + +import Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (isPrefixOf, transpose, unfoldr) + +multiCpuConfig :: IO MConfig +multiCpuConfig = + mkMConfig "Cpu: %" $ + map ("auto" ++) monitors + ++ [ k ++ n | n <- "" : map show [0 :: Int ..] + , k <- monitors] + where monitors = ["bar","total","user","nice","system","idle"] + + +cpuData :: IO [[Float]] +cpuData = do s <- B.readFile "/proc/stat" + return $ cpuParser s + +cpuParser :: B.ByteString -> [[Float]] +cpuParser = map parseList . cpuLists + where cpuLists = takeWhile isCpu . map B.words . B.lines + isCpu (w:_) = "cpu" `isPrefixOf` B.unpack w + isCpu _ = False + parseList = map (read . B.unpack) . tail + +parseCpuData :: IO [[Float]] +parseCpuData = + do (as, bs) <- doActionTwiceWithDelay 950000 cpuData + let p0 = zipWith percent bs as + return p0 + +percent :: [Float] -> [Float] -> [Float] +percent b a = if tot > 0 then map (/ tot) $ take 4 dif else [0, 0, 0, 0] + where dif = zipWith (-) b a + tot = foldr (+) 0 dif + +formatMultiCpus :: [[Float]] -> Monitor [String] +formatMultiCpus [] = return $ repeat "" +formatMultiCpus xs = fmap concat $ mapM formatCpu xs + +formatCpu :: [Float] -> Monitor [String] +formatCpu xs + | length xs < 4 = showPercentsWithColors $ replicate 6 0.0 + | otherwise = let t = foldr (+) 0 $ take 3 xs + in do b <- showPercentBar (100 * t) t + ps <- showPercentsWithColors (t:xs) + return (b:ps) + +splitEvery :: (Eq a) => Int -> [a] -> [[a]] +splitEvery n = unfoldr (\x -> if x == [] + then Nothing + else Just $ splitAt n x) + +groupData :: [String] -> [[String]] +groupData = transpose . tail . splitEvery 6 + +formatAutoCpus :: [String] -> Monitor [String] +formatAutoCpus [] = return $ replicate 6 "" +formatAutoCpus xs = return $ map unwords (groupData xs) + +runMultiCpu :: [String] -> Monitor String +runMultiCpu _ = + do c <- io parseCpuData + l <- formatMultiCpus c + a <- formatAutoCpus l + parseTemplate (a ++ l) diff --git a/src/Plugins/Monitors/Net.hs b/src/Plugins/Monitors/Net.hs new file mode 100644 index 0000000..d9cd534 --- /dev/null +++ b/src/Plugins/Monitors/Net.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Net +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A net device monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Net (netConfig, runNet) where + +import Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B + +data NetDev = NA + | ND { netDev :: String + , netRx :: Float + , netTx :: Float + } deriving (Eq,Show,Read) + +interval :: Int +interval = 500000 + +netConfig :: IO MConfig +netConfig = mkMConfig + ": KB|KB" -- template + ["dev", "rx", "tx", "rxbar", "txbar"] -- available replacements + +-- Given a list of indexes, take the indexed elements from a list. +getNElements :: [Int] -> [a] -> [a] +getNElements ns as = map (as!!) ns + +-- Split into words, with word boundaries indicated by the given predicate. +-- Drops delimiters. Duplicates 'Data.List.Split.wordsBy'. +-- +-- > map (wordsBy (`elem` " :")) ["lo:31174097 31174097", "eth0: 43598 88888"] +-- +-- will become @[["lo","31174097","31174097"], ["eth0","43598","88888"]]@ +wordsBy :: (a -> Bool) -> [a] -> [[a]] +wordsBy f s = case dropWhile f s of + [] -> [] + s' -> w : wordsBy f s'' where (w, s'') = break f s' + +readNetDev :: [String] -> NetDev +readNetDev [] = NA +readNetDev xs = + ND (xs !! 0) (r (xs !! 1)) (r (xs !! 2)) + where r s | s == "" = 0 + | otherwise = read s / 1024 + +fileNET :: IO [NetDev] +fileNET = + do f <- B.readFile "/proc/net/dev" + return $ netParser f + +netParser :: B.ByteString -> [NetDev] +netParser = + map (readNetDev . getNElements [0,1,9] . wordsBy (`elem` " :") . B.unpack) . drop 2 . B.lines + +formatNet :: Float -> Monitor (String, String) +formatNet d = do + s <- getConfigValue useSuffix + let str = if s then (++"Kb/s") . showDigits 1 else showDigits 1 + b <- showLogBar 0.9 d + x <- showWithColors str d + return (x, b) + +printNet :: NetDev -> Monitor String +printNet nd = + case nd of + ND d r t -> do (rx, rb) <- formatNet r + (tx, tb) <- formatNet t + parseTemplate [d,rx,tx,rb,tb] + NA -> return "N/A" + +parseNET :: String -> IO [NetDev] +parseNET nd = + do (a,b) <- doActionTwiceWithDelay interval fileNET + let netRate f da db = takeDigits 2 $ (f db - f da) * fromIntegral (1000000 `div` interval) + diffRate (da,db) = ND (netDev da) + (netRate netRx da db) + (netRate netTx da db) + return $ filter (\d -> netDev d == nd) $ map diffRate $ zip a b + +runNet :: [String] -> Monitor String +runNet nd = + do pn <- io $ parseNET $ head nd + n <- case pn of + [x] -> return x + _ -> return NA + printNet n diff --git a/src/Plugins/Monitors/Swap.hs b/src/Plugins/Monitors/Swap.hs new file mode 100644 index 0000000..e466dbb --- /dev/null +++ b/src/Plugins/Monitors/Swap.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Swap +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A swap usage monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Swap where + +import Plugins.Monitors.Common + +import qualified Data.ByteString.Lazy.Char8 as B + +swapConfig :: IO MConfig +swapConfig = mkMConfig + "Swap: %" -- template + ["usedratio", "total", "used", "free"] -- available replacements + +fileMEM :: IO B.ByteString +fileMEM = B.readFile "/proc/meminfo" + +parseMEM :: IO [Float] +parseMEM = + do file <- fileMEM + let li i l + | l /= [] = head l !! i + | otherwise = B.empty + fs s l + | l == [] = False + | otherwise = head l == B.pack s + get_data s = flip (/) 1024 . read . B.unpack . li 1 . filter (fs s) + st = map B.words . B.lines $ file + tot = get_data "SwapTotal:" st + free = get_data "SwapFree:" st + return [(tot - free) / tot, tot, tot - free, free] + +formatSwap :: [Float] -> Monitor [String] +formatSwap (r:xs) = + do other <- mapM (showWithColors (showDigits 2)) xs + ratio <- showPercentWithColors r + return $ ratio:other +formatSwap _ = return $ replicate 4 "N/A" + +runSwap :: [String] -> Monitor String +runSwap _ = + do m <- io parseMEM + l <- formatSwap m + parseTemplate l diff --git a/src/Plugins/Monitors/Thermal.hs b/src/Plugins/Monitors/Thermal.hs new file mode 100644 index 0000000..a3ffe6d --- /dev/null +++ b/src/Plugins/Monitors/Thermal.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Thermal +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek +-- Stability : unstable +-- Portability : unportable +-- +-- A thermal monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Thermal where + +import qualified Data.ByteString.Lazy.Char8 as B +import Plugins.Monitors.Common +import System.Posix.Files (fileExist) + +-- | Default thermal configuration. +thermalConfig :: IO MConfig +thermalConfig = mkMConfig + "Thm: C" -- template + ["temp"] -- available replacements + +-- | Retrieves thermal information. Argument is name of thermal directory in +-- \/proc\/acpi\/thermal_zone. Returns the monitor string parsed according to +-- template (either default or user specified). +runThermal :: [String] -> Monitor String +runThermal args = do + let zone = head args + file = "/proc/acpi/thermal_zone/" ++ zone ++ "/temperature" + exists <- io $ fileExist file + case exists of + False -> return $ "Thermal (" ++ zone ++ "): N/A" + True -> do number <- io $ B.readFile file + >>= return . (read :: String -> Int) + . stringParser (1, 0) + thermal <- showWithColors show number + parseTemplate [ thermal ] + diff --git a/src/Plugins/Monitors/Top.hs b/src/Plugins/Monitors/Top.hs new file mode 100644 index 0000000..e45210c --- /dev/null +++ b/src/Plugins/Monitors/Top.hs @@ -0,0 +1,179 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Top +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- Process activity and memory consumption monitors +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE ForeignFunctionInterface #-} + +module Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where + +import Plugins.Monitors.Common + +import Control.Exception (SomeException, handle) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (sortBy, foldl') +import Data.Ord (comparing) +import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) +import System.Directory (getDirectoryContents) +import System.FilePath (()) +import System.IO (IOMode(ReadMode), hGetLine, withFile) +import System.Posix.Unistd (SysVar(ClockTick), getSysVar) + +import Foreign.C.Types + +maxEntries :: Int +maxEntries = 10 + +intStrs :: [String] +intStrs = map show [1..maxEntries] + +topMemConfig :: IO MConfig +topMemConfig = mkMConfig "" + [ k ++ n | n <- intStrs , k <- ["name", "mem", "both"]] + +topConfig :: IO MConfig +topConfig = mkMConfig "" + ("no" : [ k ++ n | n <- intStrs + , k <- [ "name", "cpu", "both" + , "mname", "mem", "mboth"]]) + +foreign import ccall "unistd.h getpagesize" + c_getpagesize :: CInt + +pageSize :: Float +pageSize = fromIntegral c_getpagesize / 1024 + +processes :: IO [FilePath] +processes = fmap (filter isPid) (getDirectoryContents "/proc") + where isPid = (`elem` ['0'..'9']) . head + +getProcessData :: FilePath -> IO [String] +getProcessData pidf = + handle ign $ withFile ("/proc" pidf "stat") ReadMode readWords + where readWords = fmap words . hGetLine + ign = const (return []) :: SomeException -> IO [String] + +handleProcesses :: ([String] -> a) -> IO [a] +handleProcesses f = + fmap (foldl' (\a p -> if length p < 15 then a else f p : a) []) + (processes >>= mapM getProcessData) + +showInfo :: String -> String -> Float -> Monitor [String] +showInfo nm sms mms = do + mnw <- getConfigValue maxWidth + mxw <- getConfigValue minWidth + let lsms = length sms + nmw = mnw - lsms - 1 + nmx = mxw - lsms - 1 + rnm = if nmw > 0 then padString nmw nmx " " True nm else nm + mstr <- showWithColors' sms mms + both <- showWithColors' (rnm ++ " " ++ sms) mms + return [nm, mstr, both] + +processName :: [String] -> String +processName = drop 1 . init . (!!1) + +sortTop :: [(String, Float)] -> [(String, Float)] +sortTop = sortBy (flip (comparing snd)) + +type MemInfo = (String, Float) + +meminfo :: [String] -> MemInfo +meminfo fs = (processName fs, pageSize * parseFloat (fs!!23)) + +meminfos :: IO [MemInfo] +meminfos = handleProcesses meminfo + +showMemInfo :: Float -> MemInfo -> Monitor [String] +showMemInfo scale (nm, rss) = + showInfo nm (showWithUnits 2 1 rss) (100 * rss / sc) + where sc = if scale > 0 then scale else 100 + +showMemInfos :: [MemInfo] -> Monitor [[String]] +showMemInfos ms = mapM (showMemInfo tm) ms + where tm = sum (map snd ms) + +runTopMem :: [String] -> Monitor String +runTopMem _ = do + mis <- io meminfos + pstr <- showMemInfos (sortTop mis) + parseTemplate $ concat pstr + +type Pid = Int +type TimeInfo = (String, Float) +type TimeEntry = (Pid, TimeInfo) +type Times = [TimeEntry] +type TimesRef = IORef (Times, UTCTime) + +timeMemEntry :: [String] -> (TimeEntry, MemInfo) +timeMemEntry fs = ((p, (n, t)), (n, r)) + where p = parseInt (head fs) + n = processName fs + t = parseFloat (fs!!13) + parseFloat (fs!!14) + (_, r) = meminfo fs + +timeMemEntries :: IO [(TimeEntry, MemInfo)] +timeMemEntries = handleProcesses timeMemEntry + +timeMemInfos :: IO (Times, [MemInfo], Int) +timeMemInfos = fmap res timeMemEntries + where res x = (sortBy (comparing fst) $ map fst x, map snd x, length x) + +combine :: Times -> Times -> Times +combine _ [] = [] +combine [] ts = ts +combine l@((p0, (n0, t0)):ls) r@((p1, (n1, t1)):rs) + | p0 == p1 && n0 == n1 = (p0, (n0, t1 - t0)) : combine ls rs + | p0 <= p1 = combine ls r + | otherwise = (p1, (n1, t1)) : combine l rs + +take' :: Int -> [a] -> [a] +take' m l = let !r = tk m l in length l `seq` r + where tk 0 _ = [] + tk _ [] = [] + tk n (x:xs) = let !r = tk (n - 1) xs in x : r + +topProcesses :: TimesRef -> Float -> IO (Int, [TimeInfo], [MemInfo]) +topProcesses tref scale = do + (t0, c0) <- readIORef tref + (t1, mis, len) <- timeMemInfos + c1 <- getCurrentTime + let scx = realToFrac (diffUTCTime c1 c0) * scale + !scx' = if scx > 0 then scx else scale + nts = map (\(_, (nm, t)) -> (nm, min 100 (t / scx'))) (combine t0 t1) + !t1' = take' (length t1) t1 + !nts' = take' maxEntries (sortTop nts) + !mis' = take' maxEntries (sortTop mis) + writeIORef tref (t1', c1) + return (len, nts', mis') + +showTimeInfo :: TimeInfo -> Monitor [String] +showTimeInfo (n, t) = showInfo n (showDigits 0 t) t + +showTimeInfos :: [TimeInfo] -> Monitor [[String]] +showTimeInfos = mapM showTimeInfo + +runTop :: TimesRef -> Float -> [String] -> Monitor String +runTop tref scale _ = do + (no, ps, ms) <- io $ topProcesses tref scale + pstr <- showTimeInfos ps + mstr <- showMemInfos ms + parseTemplate $ show no : concat (zipWith (++) pstr mstr) ++ repeat "N/A" + +startTop :: [String] -> Int -> (String -> IO ()) -> IO () +startTop a r cb = do + cr <- getSysVar ClockTick + c <- getCurrentTime + tref <- newIORef ([], c) + let scale = fromIntegral cr / 100 + _ <- topProcesses tref scale + runM a topConfig (runTop tref scale) r cb diff --git a/src/Plugins/Monitors/Uptime.hs b/src/Plugins/Monitors/Uptime.hs new file mode 100644 index 0000000..8524bcc --- /dev/null +++ b/src/Plugins/Monitors/Uptime.hs @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Plugins.Monitors.Uptime +-- Copyright : (c) 2010 Jose Antonio Ortega Ruiz +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- Created: Sun Dec 12, 2010 20:26 +-- +-- +-- Uptime +-- +------------------------------------------------------------------------------ + + +module Plugins.Monitors.Uptime (uptimeConfig, runUptime) where + +import Plugins.Monitors.Common + +import qualified Data.ByteString.Lazy.Char8 as B + +uptimeConfig :: IO MConfig +uptimeConfig = mkMConfig "Up d h m" + ["days", "hours", "minutes", "seconds"] + +readUptime :: IO Float +readUptime = + fmap (read . B.unpack . head . B.words) (B.readFile "/proc/uptime") + +secsPerDay :: Integer +secsPerDay = 24 * 3600 + +uptime :: Monitor [String] +uptime = do + t <- io readUptime + u <- getConfigValue useSuffix + let tsecs = floor t + secs = tsecs `mod` secsPerDay + days = tsecs `quot` secsPerDay + hours = secs `quot` 3600 + mins = (secs `mod` 3600) `div` 60 + ss = secs `mod` 60 + str x s = if u then show x ++ s else show x + mapM (`showWithColors'` days) + [str days "d", str hours "h", str mins "m", str ss "s"] + +runUptime :: [String] -> Monitor String +runUptime _ = uptime >>= parseTemplate diff --git a/src/Plugins/Monitors/Weather.hs b/src/Plugins/Monitors/Weather.hs new file mode 100644 index 0000000..1277438 --- /dev/null +++ b/src/Plugins/Monitors/Weather.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Weather +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A weather monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Weather where + +import Plugins.Monitors.Common + +import Control.Monad (when) +import System.Process +import System.Exit +import System.IO + +import Text.ParserCombinators.Parsec + + +weatherConfig :: IO MConfig +weatherConfig = mkMConfig + ": C, rh % ()" -- template + ["station" -- available replacements + , "stationState" + , "year" + , "month" + , "day" + , "hour" + , "wind" + , "visibility" + , "skyCondition" + , "tempC" + , "tempF" + , "dewPoint" + , "rh" + , "pressure" + ] + +data WeatherInfo = + WI { stationPlace :: String + , stationState :: String + , year :: String + , month :: String + , day :: String + , hour :: String + , wind :: String + , visibility :: String + , skyCondition :: String + , tempC :: Int + , tempF :: Int + , dewPoint :: String + , humidity :: Int + , pressure :: Int + } deriving (Show) + +pTime :: Parser (String, String, String, String) +pTime = do y <- getNumbersAsString + char '.' + m <- getNumbersAsString + char '.' + d <- getNumbersAsString + char ' ' + (h:hh:mi:mimi) <- getNumbersAsString + char ' ' + return (y, m, d ,([h]++[hh]++":"++[mi]++mimi)) + +pTemp :: Parser (Int, Int) +pTemp = do let num = digit <|> char '-' <|> char '.' + f <- manyTill num $ char ' ' + manyTill anyChar $ char '(' + c <- manyTill num $ char ' ' + skipRestOfLine + return $ (floor (read c :: Double), floor (read f :: Double)) + +pRh :: Parser Int +pRh = do s <- manyTill digit $ (char '%' <|> char '.') + return $ read s + +pPressure :: Parser Int +pPressure = do manyTill anyChar $ char '(' + s <- manyTill digit $ char ' ' + skipRestOfLine + return $ read s + +parseData :: Parser [WeatherInfo] +parseData = + do st <- getAllBut "," + space + ss <- getAllBut "(" + skipRestOfLine >> getAllBut "/" + (y,m,d,h) <- pTime + w <- getAfterString "Wind: " + v <- getAfterString "Visibility: " + sk <- getAfterString "Sky conditions: " + skipTillString "Temperature: " + (tC,tF) <- pTemp + dp <- getAfterString "Dew Point: " + skipTillString "Relative Humidity: " + rh <- pRh + skipTillString "Pressure (altimeter): " + p <- pPressure + manyTill skipRestOfLine eof + return $ [WI st ss y m d h w v sk tC tF dp rh p] + +defUrl :: String +defUrl = "http://weather.noaa.gov/pub/data/observations/metar/decoded/" + +getData :: String -> IO String +getData url= + do (i,o,e,p) <- runInteractiveCommand ("curl " ++ defUrl ++ url ++ ".TXT") + exit <- waitForProcess p + let closeHandles = do hClose o + hClose i + hClose e + case exit of + ExitSuccess -> do str <- hGetContents o + when (str == str) $ return () + closeHandles + return str + _ -> do closeHandles + return "Could not retrieve data" + +formatWeather :: [WeatherInfo] -> Monitor String +formatWeather [(WI st ss y m d h w v sk tC tF dp r p)] = + do cel <- showWithColors show tC + far <- showWithColors show tF + parseTemplate [st, ss, y, m, d, h, w, v, sk, cel, far, dp, show r , show p ] +formatWeather _ = return "N/A" + +runWeather :: [String] -> Monitor String +runWeather str = + do d <- io $ getData $ head str + i <- io $ runP parseData d + formatWeather i diff --git a/src/Plugins/Monitors/Wireless.hs b/src/Plugins/Monitors/Wireless.hs new file mode 100644 index 0000000..4ac0c10 --- /dev/null +++ b/src/Plugins/Monitors/Wireless.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Wireless +-- Copyright : (c) Jose Antonio Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose Antonio Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A monitor reporting ESSID and link quality for wireless interfaces +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Wireless (wirelessConfig, runWireless) where + +import Plugins.Monitors.Common +import IWlib + +wirelessConfig :: IO MConfig +wirelessConfig = + mkMConfig " " ["essid", "quality", "qualitybar"] + +runWireless :: [String] -> Monitor String +runWireless (iface:_) = do + wi <- io $ getWirelessInfo iface + let essid = wiEssid wi + qlty = wiQuality wi + fqlty = fromIntegral qlty + e = if essid == "" then "N/A" else essid + q <- if qlty >= 0 then showWithColors show qlty else showWithPadding "" + qb <- showPercentBar fqlty (fqlty / 100) + parseTemplate [e, q, qb] +runWireless _ = return "" \ No newline at end of file diff --git a/src/Plugins/PipeReader.hs b/src/Plugins/PipeReader.hs new file mode 100644 index 0000000..3fd0dd4 --- /dev/null +++ b/src/Plugins/PipeReader.hs @@ -0,0 +1,28 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.PipeReader +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from named pipes +-- +----------------------------------------------------------------------------- + +module Plugins.PipeReader where + +import System.IO +import Plugins + +data PipeReader = PipeReader String String + deriving (Read, Show) + +instance Exec PipeReader where + alias (PipeReader _ a) = a + start (PipeReader p _) cb = do + h <- openFile p ReadWriteMode + forever (hGetLineSafe h >>= cb) + where forever a = a >> forever a diff --git a/src/Plugins/StdinReader.hs b/src/Plugins/StdinReader.hs new file mode 100644 index 0000000..2ee217e --- /dev/null +++ b/src/Plugins/StdinReader.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.StdinReader +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from stdin +-- +----------------------------------------------------------------------------- + +module Plugins.StdinReader where + +import Prelude hiding (catch) +import System.Posix.Process +import System.Exit +import System.IO +import Control.Exception (SomeException(..),catch) +import Plugins + +data StdinReader = StdinReader + deriving (Read, Show) + +instance Exec StdinReader where + start StdinReader cb = do + cb =<< catch (hGetLineSafe stdin) (\(SomeException e) -> do hPrint stderr e; return "") + eof <- hIsEOF stdin + if eof + then exitImmediately ExitSuccess + else start StdinReader cb diff --git a/src/Plugins/Utils.hs b/src/Plugins/Utils.hs new file mode 100644 index 0000000..1dbcd40 --- /dev/null +++ b/src/Plugins/Utils.hs @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Plugins.Utils +-- Copyright: (c) 2010 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: Jose A Ortega Ruiz +-- Stability: unstable +-- Portability: unportable +-- Created: Sat Dec 11, 2010 20:55 +-- +-- +-- Miscellaneous utility functions +-- +------------------------------------------------------------------------------ + + +module Plugins.Utils (expandHome, changeLoop) where + +import Control.Monad +import Control.Concurrent.STM + +import System.Environment +import System.FilePath + + +expandHome :: FilePath -> IO FilePath +expandHome ('~':'/':path) = fmap ( path) (getEnv "HOME") +expandHome p = return p + +changeLoop :: Eq a => STM a -> (a -> IO ()) -> IO () +changeLoop s f = atomically s >>= go + where + go old = do + f old + go =<< atomically (do + new <- s + guard (new /= old) + return new) diff --git a/src/Plugins/XMonadLog.hs b/src/Plugins/XMonadLog.hs new file mode 100644 index 0000000..3461e26 --- /dev/null +++ b/src/Plugins/XMonadLog.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.StdinReader +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin to display information from _XMONAD_LOG, specified at +-- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs +-- +----------------------------------------------------------------------------- + +module Plugins.XMonadLog (XMonadLog(..)) where + +import Control.Monad +import Graphics.X11 +import Graphics.X11.Xlib.Extras +import Plugins +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar) +import XUtil (nextEvent') + + +data XMonadLog = XMonadLog | XPropertyLog String + deriving (Read, Show) + +instance Exec XMonadLog where + alias XMonadLog = "XMonadLog" + alias (XPropertyLog atom) = atom + + start x cb = do + let atom = case x of + XMonadLog -> "_XMONAD_LOG" + XPropertyLog a -> a + d <- openDisplay "" + xlog <- internAtom d atom False + + root <- rootWindow d (defaultScreen d) + selectInput d root propertyChangeMask + + let update = do + mwp <- getWindowProperty8 d xlog root + maybe (return ()) (cb . decodeCChar) mwp + + update + + allocaXEvent $ \ep -> forever $ do + nextEvent' d ep + e <- getEvent ep + case e of + PropertyEvent { ev_atom = a } | a == xlog -> update + _ -> return () + + return () + +decodeCChar :: [CChar] -> String +#ifdef UTF8 +#undef UTF8 +decodeCChar = UTF8.decode . map fromIntegral +#define UTF8 +#else +decodeCChar = map (toEnum . fromIntegral) +#endif diff --git a/src/Plugins/helloworld.config b/src/Plugins/helloworld.config new file mode 100644 index 0000000..3818bfa --- /dev/null +++ b/src/Plugins/helloworld.config @@ -0,0 +1,12 @@ +Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , bgColor = "#000000" + , fgColor = "#BFBFBF" + , position = TopW C 90 + , commands = [ Run Cpu [] 10 + , Run Weather "LIPB" [] 36000 + , Run HelloWorld + ] + , sepChar = "%" + , alignSep = "}{" + , template = "%cpu% } %helloWorld% { %LIPB% | %date%" + } diff --git a/src/Runnable.hs b/src/Runnable.hs new file mode 100644 index 0000000..56fedb3 --- /dev/null +++ b/src/Runnable.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Runnable +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- The existential type to store the list of commands to be executed. +-- I must thank Claus Reinke for the help in understanding the mysteries of +-- reading existential types. The Read instance of Runnable must be credited to +-- him. +-- +-- See here: +-- http:\/\/www.haskell.org\/pipermail\/haskell-cafe\/2007-July\/028227.html +-- +----------------------------------------------------------------------------- + +module Runnable where + +import Control.Monad +import Text.Read +import Config (runnableTypes) +import Commands + +data Runnable = forall r . (Exec r, Read r, Show r) => Run r + +instance Exec Runnable where + start (Run a) = start a + alias (Run a) = alias a + +instance Show Runnable where + show (Run x) = show x + +instance Read Runnable where + readPrec = readRunnable + +class ReadAsAnyOf ts ex where + -- | Reads an existential type as any of hidden types ts + readAsAnyOf :: ts -> ReadPrec ex + +instance ReadAsAnyOf () ex where + readAsAnyOf ~() = mzero + +instance (Show t, Read t, Exec t, ReadAsAnyOf ts Runnable) => ReadAsAnyOf (t,ts) Runnable where + readAsAnyOf ~(t,ts) = r t `mplus` readAsAnyOf ts + where r ty = do { m <- readPrec; return (Run (m `asTypeOf` ty)) } + +-- | The 'Prelude.Read' parser for the 'Runnable' existential type. It +-- needs an 'Prelude.undefined' with a type signature containing the +-- list of all possible types hidden within 'Runnable'. See 'Config.runnableTypes'. +-- Each hidden type must have a 'Prelude.Read' instance. +readRunnable :: ReadPrec Runnable +readRunnable = prec 10 $ do + Ident "Run" <- lexP + parens $ readAsAnyOf runnableTypes diff --git a/src/Runnable.hs-boot b/src/Runnable.hs-boot new file mode 100644 index 0000000..eba90e6 --- /dev/null +++ b/src/Runnable.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Runnable where +import Commands + +data Runnable = forall r . (Exec r,Read r,Show r) => Run r + +instance Read Runnable +instance Exec Runnable diff --git a/src/StatFS.hsc b/src/StatFS.hsc new file mode 100644 index 0000000..21ee731 --- /dev/null +++ b/src/StatFS.hsc @@ -0,0 +1,79 @@ +----------------------------------------------------------------------------- +-- | +-- Module : StatFS +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A binding to C's statvfs(2) +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} + + +module StatFS ( FileSystemStats(..), getFileSystemStats ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Data.ByteString (useAsCString) +import Data.ByteString.Char8 (pack) + +#if defined (__FreeBSD__) +# include +# include +#else +#include +#endif + +data FileSystemStats = FileSystemStats { + fsStatBlockSize :: Integer + -- ^ Optimal transfer block size. + , fsStatBlockCount :: Integer + -- ^ Total data blocks in file system. + , fsStatByteCount :: Integer + -- ^ Total bytes in file system. + , fsStatBytesFree :: Integer + -- ^ Free bytes in file system. + , fsStatBytesAvailable :: Integer + -- ^ Free bytes available to non-superusers. + , fsStatBytesUsed :: Integer + -- ^ Bytes used. + } deriving (Show, Eq) + +data CStatfs + +#if defined(__FreeBSD__) +foreign import ccall unsafe "sys/mount.h statfs" +#else +foreign import ccall unsafe "sys/vfs.h statfs64" +#endif + c_statfs :: CString -> Ptr CStatfs -> IO CInt + +toI :: CLong -> Integer +toI = toInteger + +getFileSystemStats :: String -> IO (Maybe FileSystemStats) +getFileSystemStats path = + allocaBytes (#size struct statfs) $ \vfs -> + useAsCString (pack path) $ \cpath -> do + res <- c_statfs cpath vfs + if res == -1 then return Nothing + else do + bsize <- (#peek struct statfs, f_bsize) vfs + bcount <- (#peek struct statfs, f_blocks) vfs + bfree <- (#peek struct statfs, f_bfree) vfs + bavail <- (#peek struct statfs, f_bavail) vfs + let bpb = toI bsize + return $ Just FileSystemStats + { fsStatBlockSize = bpb + , fsStatBlockCount = toI bcount + , fsStatByteCount = toI bcount * bpb + , fsStatBytesFree = toI bfree * bpb + , fsStatBytesAvailable = toI bavail * bpb + , fsStatBytesUsed = toI (bcount - bfree) * bpb + } diff --git a/src/XUtil.hsc b/src/XUtil.hsc new file mode 100644 index 0000000..d5bb591 --- /dev/null +++ b/src/XUtil.hsc @@ -0,0 +1,259 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : XUtil +-- Copyright : (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : andrea.rossato@unitn.it +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module XUtil + ( XFont + , initFont + , initCoreFont + , initUtf8Font + , textExtents + , textWidth + , printString + , initColor + , newWindow + , nextEvent' + , readFileSafe + , hGetLineSafe + , io + , fi + , withColors + , DynPixel(..) + ) where + +import Control.Concurrent +import Control.Monad.Trans +import Data.IORef +import Foreign +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import System.Mem.Weak ( addFinalizer ) +import System.Posix.Types (Fd(..)) +import System.IO +#if defined XFT || defined UTF8 +# if __GLASGOW_HASKELL__ < 612 +import Foreign.C +import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine) +# else +import qualified System.IO as UTF8 (readFile,hGetLine) +# endif +#endif +#if defined XFT +import Data.List +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +readFileSafe :: FilePath -> IO String +#if defined XFT || defined UTF8 +readFileSafe = UTF8.readFile +#else +readFileSafe = readFile +#endif + +hGetLineSafe :: Handle -> IO String +#if defined XFT || defined UTF8 +hGetLineSafe = UTF8.hGetLine +#else +hGetLineSafe = hGetLine +#endif + +-- Hide the Core Font/Xft switching here +data XFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft XftFont +#endif + +-- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend +-- Example: 'xft:Sans-10' +initFont :: Display ->String -> IO XFont +initFont d s = +#ifdef XFT + let xftPrefix = "xft:" in + if xftPrefix `isPrefixOf` s then + fmap Xft $ initXftFont d s + else +#endif +#if defined UTF8 || __GLASGOW_HASKELL__ >= 612 + fmap Utf8 $ initUtf8Font d s +#else + fmap Core $ initCoreFont d s +#endif + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initCoreFont :: Display -> String -> IO FontStruct +initCoreFont d s = do + f <- catch getIt fallBack + addFinalizer f (freeFont d f) + return f + where getIt = loadQueryFont d s + fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initUtf8Font :: Display -> String -> IO FontSet +initUtf8Font d s = do + setupLocale + (_,_,f) <- catch getIt fallBack + addFinalizer f (freeFontSet d f) + return f + where getIt = createFontSet d s + fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +#ifdef XFT +initXftFont :: Display -> String -> IO XftFont +initXftFont d s = do + setupLocale + f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s) + addFinalizer f (xftFontClose d f) + return f +#endif + +textWidth :: Display -> XFont -> String -> IO Int +textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s +textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s +#ifdef XFT +textWidth dpy (Xft xftdraw) s = do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtents :: XFont -> String -> IO (Int32,Int32) +textExtents (Core fs) s = do + let (_,a,d,_) = Xlib.textExtents fs s + return (a,d) +textExtents (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + (fi $ rect_y rl) + return (ascent, descent) +#ifdef XFT +textExtents (Xft xftfont) _ = do + ascent <- fi `fmap` xftfont_ascent xftfont + descent <- fi `fmap` xftfont_descent xftfont + return (ascent, descent) +#endif + +printString :: Display -> Drawable -> XFont -> GC -> String -> String + -> Position -> Position -> String -> IO () +printString d p (Core fs) gc fc bc x y s = do + setFont d gc $ fontFromFontStruct fs + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + setBackground d gc bc' + drawImageString d p gc x y s + +printString d p (Utf8 fs) gc fc bc x y s = + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + setBackground d gc bc' + io $ wcDrawImageString d p fs gc x y s + +#ifdef XFT +printString dpy drw fs@(Xft font) gc fc bc x y s = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + withColors dpy [bc] $ \[bcolor] -> do + (a,d) <- textExtents fs s + gi <- xftTextExtents dpy font s + setForeground dpy gc bcolor + fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) + (y - fi (a + d)) + (fi $ xglyphinfo_xOff gi) + (fi $ 4 + a + d) + withXftDraw dpy drw visual colormap $ + \draw -> withXftColorName dpy visual colormap fc $ + \color -> xftDrawString draw color font x (y - 2) s +#endif + +data DynPixel = DynPixel { allocated :: Bool + , pixel :: Pixel + } + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +initColor :: Display -> String -> IO DynPixel +initColor dpy c = (initColor' dpy c) `catch` + (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) + +type ColorCache = [(String, Color)] +{-# NOINLINE colorCache #-} +colorCache :: IORef ColorCache +colorCache = unsafePerformIO $ newIORef [] + +getCachedColor :: String -> IO (Maybe Color) +getCachedColor color_name = lookup color_name `fmap` readIORef colorCache + +putCachedColor :: String -> Color -> IO () +putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c + +initColor' :: Display -> String -> IO DynPixel +initColor' dpy c = do + let colormap = defaultColormap dpy (defaultScreen dpy) + cached_color <- getCachedColor c + c' <- case cached_color of + Just col -> return col + _ -> do (c'', _) <- allocNamedColor dpy colormap c + putCachedColor c c'' + return c'' + return $ DynPixel True (color_pixel c') + +withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a +withColors d cs f = do + ps <- mapM (io . initColor d) cs + f $ map pixel ps + +-- | Creates a window with the attribute override_redirect set to True. +-- Windows Managers should not touch this kind of windows. +newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window +newWindow dpy scr rw (Rectangle x y w h) o = do + let visual = defaultVisualOfScreen scr + attrmask = cWOverrideRedirect + allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes o + createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) + inputOutput visual attrmask attributes +-- | A version of nextEvent that does not block in foreign calls. +nextEvent' :: Display -> XEventPtr -> IO () +nextEvent' d p = do + pend <- pending d + if pend /= 0 + then nextEvent d p + else do + threadWaitRead (Fd fd) + nextEvent' d p + where + fd = connectionNumber d + +io :: MonadIO m => IO a -> m a +io = liftIO + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +#if __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8) +#include +foreign import ccall unsafe "locale.h setlocale" + setlocale :: CInt -> CString -> IO CString + +setupLocale :: IO () +setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return () +# else +setupLocale :: IO () +setupLocale = return () +#endif diff --git a/src/Xmobar.hs b/src/Xmobar.hs new file mode 100644 index 0000000..2f5aa3c --- /dev/null +++ b/src/Xmobar.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A status bar for the Xmonad Window Manager +-- +----------------------------------------------------------------------------- + +module Xmobar + ( -- * Main Stuff + -- $main + X , XConf (..), runX + , eventLoop + -- * Program Execution + -- $command + , startCommand + -- * Window Management + -- $window + , createWin, updateWin + -- * Printing + -- $print + , drawInWin, printStrings + ) where + +import Prelude hiding (catch) +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama + +import Control.Arrow ((&&&)) +import Control.Monad.Reader +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception hiding (handle) +import Data.Bits +import Data.Maybe(fromMaybe) +import Data.Typeable (Typeable) + +import Config +import Parsers +import Commands +import Runnable +import XUtil + +-- $main +-- +-- The Xmobar data type and basic loops and functions. + +-- | The X type is a ReaderT +type X = ReaderT XConf IO + +-- | The ReaderT inner component +data XConf = + XConf { display :: Display + , rect :: Rectangle + , window :: Window + , fontS :: XFont + , config :: Config + } + +-- | Runs the ReaderT +runX :: XConf -> X () -> IO () +runX xc f = runReaderT f xc + +data WakeUp = WakeUp deriving (Show,Typeable) +instance Exception WakeUp + +-- | The event loop +eventLoop :: XConf -> [(Maybe ThreadId, TVar String)] -> IO () +eventLoop xc@(XConf d _ w fs c) v = block $ do + tv <- atomically $ newTVar [] + t <- myThreadId + ct <- forkIO (checker t tv "" `catch` \(SomeException _) -> return ()) + go tv ct + where + -- interrupt the drawing thread every time a var is updated + checker t tvar ov = do + nval <- atomically $ do + nv <- fmap concat $ mapM readTVar (map snd v) + guard (nv /= ov) + writeTVar tvar nv + return nv + throwTo t WakeUp + checker t tvar nval + + -- Continuously wait for a timer interrupt or an expose event + go tv ct = do + catch (unblock $ allocaXEvent $ \e -> + handle tv ct =<< (nextEvent' d e >> getEvent e)) + (\WakeUp -> runX xc (updateWin tv) >> return ()) + go tv ct + + -- event hanlder + handle _ ct (ConfigureEvent {ev_window = win}) = do + rootw <- rootWindow d (defaultScreen d) + when (win == rootw) $ block $ do + killThread ct + destroyWindow d w + (r',w') <- createWin d fs c + eventLoop (XConf d r' w' fs c) v + + handle tvar _ (ExposeEvent {}) = runX xc (updateWin tvar) + + handle _ _ _ = return () + +-- $command + +-- | Runs a command as an independent thread and returns its thread id +-- and the TVar the command will be writing to. +startCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, TVar String) +startCommand (com,s,ss) + | alias com == "" = do var <- atomically $ newTVar is + atomically $ writeTVar var "Could not parse the template" + return (Nothing,var) + | otherwise = do var <- atomically $ newTVar is + let cb str = atomically $ writeTVar var (s ++ str ++ ss) + h <- forkIO $ start com cb + return (Just h,var) + where is = s ++ "Updating..." ++ ss + +-- $window + +-- | The function to create the initial window +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) +createWin d fs c = do + let dflt = defaultScreen d + srs <- getScreenInfo d + rootw <- rootWindow d dflt + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + (r,o) = setPosition (position c) srs (fi ht) + win <- newWindow d (defaultScreenOfDisplay d) rootw r o + selectInput d win (exposureMask .|. structureNotifyMask) + setProperties r c d win srs + when (lowerOnStart c) (lowerWindow d win) + mapWindow d win + return (r,win) + +setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) +setPosition p rs ht = + case p' of + Top -> (Rectangle rx ry rw h , True) + TopW a i -> (Rectangle (ax a i ) ry (nw i ) h , True) + TopSize a i ch -> (Rectangle (ax a i ) ry (nw i ) (mh ch), True) + Bottom -> (Rectangle rx ny rw h , True) + BottomW a i -> (Rectangle (ax a i ) ny (nw i ) h , True) + BottomSize a i ch -> (Rectangle (ax a i ) ny (nw i ) (mh ch), True) + Static cx cy cw ch -> (Rectangle (fi cx ) (fi cy) (fi cw) (fi ch), True) + OnScreen _ p'' -> setPosition p'' [scr] ht + where + (scr@(Rectangle rx ry rw rh), p') = + case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) + _ -> (head rs, p) + ny = ry + fi (rh - ht) + center i = rx + (fi $ div (remwid i) 2) + right i = rx + (fi $ remwid i) + remwid i = rw - pw (fi i) + ax L = const rx + ax R = right + ax C = center + pw i = rw * (min 100 i) `div` 100 + nw = fi . pw . fi + h = fi ht + mh h' = max (fi h') h + + safeIndex i = lookup i . zip [0..] + +setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () +setProperties r c d w srs = do + a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False + c1 <- internAtom d "CARDINAL" False + a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False + c2 <- internAtom d "ATOM" False + v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False + changeProperty32 d w a1 c1 propModeReplace $ map fi $ + getStrutValues r (position c) (getRootWindowHeight srs) + changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] + +getRootWindowHeight :: [Rectangle] -> Int +getRootWindowHeight srs = foldr1 max (map getMaxScreenYCoord srs) + where + getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) + +getStrutValues :: Rectangle -> XPosition -> Int -> [Int] +getStrutValues r@(Rectangle x y w h) p rwh = + case p of + OnScreen _ p' -> getStrutValues r p' rwh + Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + Static _ _ _ _ -> getStaticStrutValues p rwh + where st = fi y + fi h + sb = rwh - fi y + nx = fi x + nw = fi (x + fi w - 1) + +-- get some reaonable strut values for static placement. +getStaticStrutValues :: XPosition -> Int -> [Int] +getStaticStrutValues (Static cx cy cw ch) rwh + -- if the yPos is in the top half of the screen, then assume a Top + -- placement, otherwise, it's a Bottom placement + | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] + | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] + where st = cy + ch + sb = rwh - cy + xs = cx -- a simple calculation for horizontal (x) placement + xe = xs + cw +getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + +updateWin :: TVar String -> X () +updateWin v = do + xc <- ask + let (conf,rec) = (config &&& rect) xc + [lc,rc] = if length (alignSep conf) == 2 + then alignSep conf + else alignSep defaultConfig + i <- io $ atomically $ readTVar v + let def = [i,[],[]] + [l,c,r] = case break (==lc) i of + (le,_:re) -> case break (==rc) re of + (ce,_:ri) -> [le,ce,ri] + _ -> def + _ -> def + ps <- io $ mapM (parseString conf) [l,c,r] + drawInWin rec ps + +-- $print + +-- | Draws in and updates the window +drawInWin :: Rectangle -> [[(String, String)]] -> X () +drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do + r <- ask + let (c,d ) = (config &&& display) r + (w,fs) = (window &&& fontS ) r + strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw)) + withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do + gc <- io $ createGC d w + -- create a pixmap to write to and fill it with a rectangle + p <- io $ createPixmap d w wid ht + (defaultDepthOfScreen (defaultScreenOfDisplay d)) + -- the fgcolor of the rectangle will be the bgcolor of the window + io $ setForeground d gc bgcolor + io $ fillRectangle d p gc 0 0 wid ht + -- write to the pixmap the new string + printStrings p gc fs 1 L =<< strLn left + printStrings p gc fs 1 R =<< strLn right + printStrings p gc fs 1 C =<< strLn center + -- draw 1 pixel border if requested + io $ drawBorder (border c) d p gc bdcolor wid ht + -- copy the pixmap with the new string to the window + io $ copyArea d p w gc 0 0 wid ht 0 0 + -- free up everything (we do not want to leak memory!) + io $ freeGC d gc + io $ freePixmap d p + -- resync + io $ sync d True + +drawBorder :: Border -> Display -> Drawable -> GC -> Pixel -> Dimension + -> Dimension -> IO () +drawBorder b d p gc c wi ht = case b of + NoBorder -> return () + TopB -> drawBorder (TopBM 0) d p gc c w h + BottomB -> drawBorder (BottomBM 0) d p gc c w h + FullB -> drawBorder (FullBM 0) d p gc c w h + TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 + BottomBM m -> let rw = (fi h) - (fi m) in + sf >> drawLine d p gc 0 rw (fi w) rw + FullBM m -> let rm = fi m; mp = fi m in + sf >> drawRectangle d p gc mp mp (w - rm) (h - rm) + where sf = setForeground d gc c + (w, h) = (wi - 1, ht - 1) + +-- | An easy way to print the stuff we need to print +printStrings :: Drawable -> GC -> XFont -> Position + -> Align -> [(String, String, Position)] -> X () +printStrings _ _ _ _ _ [] = return () +printStrings dr gc fontst offs a sl@((s,c,l):xs) = do + r <- ask + (as,ds) <- io $ textExtents fontst s + let (conf,d) = (config &&& display) r + Rectangle _ _ wid ht = rect r + totSLen = foldr (\(_,_,len) -> (+) len) 0 sl + valign = fi $ as + ds + remWidth = fi wid - fi totSLen + offset = case a of + C -> (remWidth + offs) `div` 2 + R -> remWidth + L -> offs + (fc,bc) = case (break (==',') c) of + (f,',':b) -> (f, b ) + (f, _) -> (f, bgColor conf) + withColors d [bc] $ \[bc'] -> do + io $ setForeground d gc bc' + io $ fillRectangle d dr gc offset 0 (fi l) ht + io $ printString d dr fontst gc fc bc offset valign s + printStrings dr gc fontst (offs + l) a xs diff --git a/xmobar.cabal b/xmobar.cabal index d1eb571..d46c8eb 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -47,8 +47,9 @@ flag all_extensions default: False executable xmobar + hs-source-dirs: src main-is: Main.hs - other-modules: Xmobar, Config, Parsers, Commands, XUtil, StatFS, Runnable, Plugins + other-modules: Xmobar, Config, Parsers, Commands, XUtil, StatFS, Runnable, Plugins, Plugins.Monitors ghc-prof-options: -prof -auto-all if true -- cgit v1.2.3