summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Commands.hs84
-rw-r--r--src/Config.hs116
-rw-r--r--src/IWlib.hsc75
-rw-r--r--src/Main.hs164
-rw-r--r--src/Parsers.hs183
-rw-r--r--src/Plugins.hs25
-rw-r--r--src/Plugins/CommandReader.hs39
-rw-r--r--src/Plugins/Date.hs37
-rw-r--r--src/Plugins/EWMH.hs264
-rw-r--r--src/Plugins/HelloWorld.hs24
-rw-r--r--src/Plugins/MBox.hs111
-rw-r--r--src/Plugins/Mail.hs70
-rw-r--r--src/Plugins/Monitors.hs119
-rw-r--r--src/Plugins/Monitors/Batt.hs165
-rw-r--r--src/Plugins/Monitors/Common.hs446
-rw-r--r--src/Plugins/Monitors/CoreCommon.hs59
-rw-r--r--src/Plugins/Monitors/CoreTemp.hs41
-rw-r--r--src/Plugins/Monitors/Cpu.hs53
-rw-r--r--src/Plugins/Monitors/CpuFreq.hs43
-rw-r--r--src/Plugins/Monitors/Disk.hs137
-rw-r--r--src/Plugins/Monitors/MPD.hs115
-rw-r--r--src/Plugins/Monitors/Mem.hs59
-rw-r--r--src/Plugins/Monitors/MultiCpu.hs81
-rw-r--r--src/Plugins/Monitors/Net.hs96
-rw-r--r--src/Plugins/Monitors/Swap.hs55
-rw-r--r--src/Plugins/Monitors/Thermal.hs42
-rw-r--r--src/Plugins/Monitors/Top.hs179
-rw-r--r--src/Plugins/Monitors/Uptime.hs50
-rw-r--r--src/Plugins/Monitors/Weather.hs141
-rw-r--r--src/Plugins/Monitors/Wireless.hs34
-rw-r--r--src/Plugins/PipeReader.hs28
-rw-r--r--src/Plugins/StdinReader.hs33
-rw-r--r--src/Plugins/Utils.hs39
-rw-r--r--src/Plugins/XMonadLog.hs72
-rw-r--r--src/Plugins/helloworld.config12
-rw-r--r--src/Runnable.hs59
-rw-r--r--src/Runnable.hs-boot8
-rw-r--r--src/StatFS.hsc79
-rw-r--r--src/XUtil.hsc259
-rw-r--r--src/Xmobar.hs306
40 files changed, 4002 insertions, 0 deletions
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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- 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% }{ <fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>"
+ }
+
+
+-- | 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 <jao@gnu.org>
+-- 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 <iwlib.h>
+
+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 <jao@gnu.org>
+-- 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 = "<xmobar@projects.haskell.org>"
+
+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 <jao@gnu.org>
+-- 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 "<fc=") (string ">") colors
+ s <- manyTill (textParser c <|> colorParser) (try $ string "</fc>")
+ 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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A date plugin for Xmobar
+--
+-- Usage example: in template put
+--
+-- > Run Date "%a %b %_d %Y <fc=#ee9a00> %H:%M:%S</fc>" "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 <spencerjanssen@gmail.com>
+-- 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 ["<fc=", fg, if null bg then "" else "," ++ bg
+ , ">", x, "</fc>"]
+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 <jao@gnu.org>
+-- 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 "<fc=red>Hello World!!</fc>"
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 <jao@gnu.org>
+-- 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 "<fc=" ++ c ++ ">" ++ msg ++ "</fc>"
+ 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 <sjanssen@cse.unl.edu>
+-- 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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- 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: <watts>, <left>% / <timeleft>" -- 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 = "<fc=" ++ c ++ ">" ++ str ++ "</fc>"
+ 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 <jao@gnu.org>
+-- 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 "</fc>") <|> try (
+ do string "<fc="
+ s <- many1 (alphaNum <|> char ',' <|> char '#')
+ char '>'
+ return $ "<fc=" ++ s ++ ">")
+
+-- | 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 $
+ "<fc=" ++ c ++ ">" ++ str ++ "</fc>"
+
+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 <juhe_haskell@hck.sk>
+-- 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 <juhe_haskell@hck.sk>
+-- 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: <core0>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 <jao@gnu.org>
+-- 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: <total>%"
+ ["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 <juhe_haskell@hck.sk>
+-- 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: <cpu0>" -- 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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- 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: <state>"
+ [ "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 <jao@gnu.org>
+-- 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: <usedratio>% (<cache>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 <jao@gnu.org>
+-- 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: <total>%" $
+ 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 <jao@gnu.org>
+-- 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
+ "<dev>: <rx>KB|<tx>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 <jao@gnu.org>
+-- 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: <usedratio>%" -- 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 <juhe_haskell@hck.sk>
+-- 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: <temp>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 <jao@gnu.org>
+-- 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 "<both1>"
+ [ k ++ n | n <- intStrs , k <- ["name", "mem", "both"]]
+
+topConfig :: IO MConfig
+topConfig = mkMConfig "<both1>"
+ ("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 <days>d <hours>h <minutes>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 <jao@gnu.org>
+-- 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
+ "<station>: <tempC>C, rh <rh>% (<hour>)" -- 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>" ["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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- 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 <spencerjanssen@gmail.com>
+-- 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% | <fc=yellow>%date%</fc>"
+ }
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 <jao@gnu.org>
+-- 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 <jao@gnu.org>
+-- 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 <sys/param.h>
+# include <sys/mount.h>
+#else
+#include <sys/vfs.h>
+#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 <locale.h>
+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 <jao@gnu.org>
+-- 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