diff options
Diffstat (limited to 'src/Xmobar/Plugins/Monitors/Common.hs')
| -rw-r--r-- | src/Xmobar/Plugins/Monitors/Common.hs | 544 |
1 files changed, 0 insertions, 544 deletions
diff --git a/src/Xmobar/Plugins/Monitors/Common.hs b/src/Xmobar/Plugins/Monitors/Common.hs deleted file mode 100644 index 272690b..0000000 --- a/src/Xmobar/Plugins/Monitors/Common.hs +++ /dev/null @@ -1,544 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 |