module Xmobar.Plugins.Monitors.Common (
Monitor
, MConfig (..)
, Opts (..)
, setConfigValue
, getConfigValue
, mkMConfig
, runM
, runMD
, runMB
, runMBD
, io
, runP
, skipRestOfLine
, getNumbers
, getNumbersAsString
, getAllBut
, getAfterString
, skipTillString
, parseTemplate
, parseTemplate'
, IconPattern
, parseIconPattern
, padString
, showWithPadding
, showWithColors
, showWithColors'
, showPercentWithColors
, showPercentsWithColors
, showPercentBar
, showVerticalBar
, showIconPattern
, showLogBar
, showLogVBar
, showLogIconPattern
, showWithUnits
, takeDigits
, showDigits
, floatToPercent
, parseFloat
, parseInt
, stringParser
) where
import Control.Applicative ((<$>))
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 Data.Char
import Numeric
import Text.ParserCombinators.Parsec
import System.Console.GetOpt
import Control.Exception (SomeException,handle)
import Xmobar.Run.Commands
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
, decDigits :: IORef Int
, minWidth :: IORef Int
, maxWidth :: IORef Int
, maxWidthEllipsis :: IORef String
, padChars :: IORef String
, padRight :: IORef Bool
, barBack :: IORef String
, barFore :: IORef String
, barWidth :: IORef Int
, useSuffix :: IORef Bool
, naString :: IORef String
, maxTotalWidth :: IORef Int
, maxTotalWidthEllipsis :: IORef String
}
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 (const 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
d <- newIORef 0
mn <- newIORef 0
mx <- newIORef 0
mel <- newIORef ""
pc <- newIORef " "
pr <- newIORef False
bb <- newIORef ":"
bf <- newIORef "#"
bw <- newIORef 10
up <- newIORef False
na <- newIORef "N/A"
mt <- newIORef 0
mtel <- newIORef ""
return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel
data Opts = HighColor String
| NormalColor String
| LowColor String
| Low String
| High String
| Template String
| PercentPad String
| DecDigits String
| MinWidth String
| MaxWidth String
| Width String
| WidthEllipsis String
| PadChars String
| PadAlign String
| BarBack String
| BarFore String
| BarWidth String
| UseSuffix String
| NAString String
| MaxTotalWidth String
| MaxTotalWidthEllipsis 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 "d" ["ddigits"] (ReqArg DecDigits "decimal digits") "Number of decimal digits to display."
, 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 "e" ["maxwidthellipsis"] (ReqArg WidthEllipsis "Maximum width ellipsis") "Ellipsis to be added to the field when it has reached its max 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"
, Option "x" ["nastring"] (ReqArg NAString "N/A string") "String used when the monitor is not available"
, Option "T" ["maxtwidth"] (ReqArg MaxTotalWidth "Maximum total width") "Maximum total width"
, Option "E" ["maxtwidthellipsis"] (ReqArg MaxTotalWidthEllipsis "Maximum total width ellipsis") "Ellipsis to be added to the total text when it has reached its max width."
]
doArgs :: [String] -> ([String] -> Monitor String) -> ([String] -> Monitor Bool) -> Monitor String
doArgs args action detect =
case getOpt Permute options args of
(o, n, []) -> do doConfigOptions o
ready <- detect n
if ready
then action n
else return "<Waiting...>"
(_, _, 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
DecDigits d -> setConfigValue (nz d) decDigits
MinWidth w -> setConfigValue (nz w) minWidth
MaxWidth w -> setConfigValue (nz w) maxWidth
Width w -> setConfigValue (nz w) minWidth >>
setConfigValue (nz w) maxWidth
WidthEllipsis e -> setConfigValue e maxWidthEllipsis
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
NAString s -> setConfigValue s naString
MaxTotalWidth w -> setConfigValue (nz w) maxTotalWidth
MaxTotalWidthEllipsis e -> setConfigValue e maxTotalWidthEllipsis) >> next
runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int
-> (String -> IO ()) -> IO ()
runM args conf action r = runMB args conf action (tenthSeconds r)
runMD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int
-> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO ()
runMD args conf action r = runMBD args conf action (tenthSeconds r)
runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO ()
-> (String -> IO ()) -> IO ()
runMB args conf action wait = runMBD args conf action wait (\_ -> return True)
runMBD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO ()
-> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO ()
runMBD args conf action wait detect cb = handle (cb . showException) loop
where ac = doArgs args action detect
loop = conf >>= runReaderT ac >>= cb >> wait >> loop
showException :: SomeException -> String
showException = ("error: "++) . show . flip asTypeOf undefined
io :: IO a -> Monitor a
io = liftIO
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
templateStringParser :: Parser (String,String,String)
templateStringParser =
do { s <- nonPlaceHolder
; com <- templateCommandParser
; ss <- nonPlaceHolder
; return (s, com, ss)
}
where
nonPlaceHolder = fmap concat . many $
many1 (noneOf "<") <|> colorSpec <|> iconSpec
colorSpec :: Parser String
colorSpec = try (string "</fc>") <|> try (
do string "<fc="
s <- many1 (alphaNum <|> char ',' <|> char '#')
char '>'
return $ "<fc=" ++ s ++ ">")
iconSpec :: Parser String
iconSpec = try (do string "<icon="
i <- manyTill (noneOf ">") (try (string "/>"))
return $ "<icon=" ++ i ++ "/>")
templateCommandParser :: Parser String
templateCommandParser =
do { char '<'
; com <- many $ noneOf ">"
; char '>'
; return com
}
templateParser :: Parser [(String,String,String)]
templateParser = many templateStringParser
trimTo :: Int -> String -> String -> (Int, String)
trimTo n p "" = (n, p)
trimTo n p ('<':cs) = trimTo n p' s
where p' = p ++ "<" ++ takeWhile (/= '>') cs ++ ">"
s = drop 1 (dropWhile (/= '>') cs)
trimTo 0 p s = trimTo 0 p (dropWhile (/= '<') s)
trimTo n p s = let p' = takeWhile (/= '<') s
s' = dropWhile (/= '<') s
in
if length p' <= n
then trimTo (n - length p') (p ++ p') s'
else trimTo 0 (p ++ take n p') s'
parseTemplate :: [String] -> Monitor String
parseTemplate l =
do t <- getConfigValue template
e <- getConfigValue export
w <- getConfigValue maxTotalWidth
ell <- getConfigValue maxTotalWidthEllipsis
let m = Map.fromList . zip e $ l
s <- parseTemplate' t m
let (n, s') = if w > 0 && length s > w
then trimTo (w - length ell) "" s
else (1, s)
return $ if n > 0 then s' else s' ++ ell
parseTemplate' :: String -> Map.Map String String -> Monitor String
parseTemplate' t m =
do s <- io $ runP templateParser t
combine m s
combine :: Map.Map String String -> [(String, String, String)] -> Monitor String
combine _ [] = return []
combine m ((s,ts,ss):xs) =
do next <- combine m xs
str <- case Map.lookup ts m of
Nothing -> return $ "<" ++ ts ++ ">"
Just r -> let f "" = r; f n = n; in f <$> parseTemplate' r m
return $ s ++ str ++ ss ++ next
type IconPattern = Int -> String
parseIconPattern :: String -> IconPattern
parseIconPattern path =
let spl = splitOnPercent path
in \i -> intercalate (show i) spl
where splitOnPercent [] = [[]]
splitOnPercent ('%':'%':xs) = [] : splitOnPercent xs
splitOnPercent (x:xs) =
let rest = splitOnPercent xs
in (x : head rest) : tail rest
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 -> String
padString mnw mxw pad pr ellipsis 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 ++ ellipsis
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
ellipsis <- getConfigValue maxWidthEllipsis
return $ padString mn mx p pr ellipsis 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]
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 = fmap 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)
showIconPattern :: Maybe IconPattern -> Float -> Monitor String
showIconPattern Nothing _ = return ""
showIconPattern (Just str) x = return $ str $ convert $ 100 * x
where convert val
| t <= 0 = 0
| t > 8 = 8
| otherwise = t
where t = round val `div` 12
showVerticalBar :: Float -> Float -> Monitor String
showVerticalBar v x = colorizeString v [convert $ 100 * x]
where convert :: Float -> Char
convert val
| t <= 9600 = ' '
| t > 9608 = chr 9608
| otherwise = chr t
where t = 9600 + (round val `div` 12)
logScaling :: Float -> Float -> Monitor Float
logScaling f v = do
h <- fromIntegral `fmap` getConfigValue high
l <- fromIntegral `fmap` getConfigValue low
bw <- fromIntegral `fmap` getConfigValue barWidth
let [ll, hh] = sort [l, h]
scaled x | x == 0.0 = 0
| x <= ll = 1 / bw
| otherwise = f + logBase 2 (x / hh) / bw
return $ scaled v
showLogBar :: Float -> Float -> Monitor String
showLogBar f v = logScaling f v >>= showPercentBar v
showLogVBar :: Float -> Float -> Monitor String
showLogVBar f v = logScaling f v >>= showVerticalBar v
showLogIconPattern :: Maybe IconPattern -> Float -> Float -> Monitor String
showLogIconPattern str f v = logScaling f v >>= showIconPattern str