diff options
Diffstat (limited to 'src/lib/Xmobar/Plugins/Monitors/Common.hs')
| -rw-r--r-- | src/lib/Xmobar/Plugins/Monitors/Common.hs | 544 |
1 files changed, 544 insertions, 0 deletions
diff --git a/src/lib/Xmobar/Plugins/Monitors/Common.hs b/src/lib/Xmobar/Plugins/Monitors/Common.hs new file mode 100644 index 0000000..272690b --- /dev/null +++ b/src/lib/Xmobar/Plugins/Monitors/Common.hs @@ -0,0 +1,544 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Common +-- Copyright : (c) 2010, 2011, 2013, 2016, 2017, 2018 Jose Antonio Ortega Ruiz +-- (c) 2007-2010 Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Utilities used by xmobar's monitors +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Common ( + -- * Monitors + -- $monitor + Monitor + , MConfig (..) + , Opts (..) + , setConfigValue + , getConfigValue + , mkMConfig + , runM + , runMD + , runMB + , runMBD + , io + -- * Parsers + -- $parsers + , runP + , skipRestOfLine + , getNumbers + , getNumbersAsString + , getAllBut + , getAfterString + , skipTillString + , parseTemplate + , parseTemplate' + -- ** String Manipulation + -- $strings + , 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.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 + , 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 + } + +-- | 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 (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 + +-- $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 = fmap concat . many $ + many1 (noneOf "<") <|> colorSpec <|> iconSpec + +-- | 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 ++ ">") + +-- | Recognizes icon specification and returns it unchanged +iconSpec :: Parser String +iconSpec = try (do string "<icon=" + i <- manyTill (noneOf ">") (try (string "/>")) + return $ "<icon=" ++ i ++ "/>") + +-- | 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 --"%") + +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' + +-- | 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, trimmed to MaxTotalWidth if that +-- configuration value is positive. +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 + +-- | Parses the template given to it with a map of export values and combines +-- them +parseTemplate' :: String -> Map.Map String String -> Monitor String +parseTemplate' t m = + do s <- io $ runP templateParser t + combine m s + +-- | Given a finite "Map" and a parsed template t produces the +-- | resulting output string as the output of the monitor. +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 + +-- $strings + +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] -- 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 = 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 |