diff options
Diffstat (limited to 'Plugins/Monitors/Common.hs')
| -rw-r--r-- | Plugins/Monitors/Common.hs | 446 |
1 files changed, 0 insertions, 446 deletions
diff --git a/Plugins/Monitors/Common.hs b/Plugins/Monitors/Common.hs deleted file mode 100644 index cc1a6a7..0000000 --- a/Plugins/Monitors/Common.hs +++ /dev/null @@ -1,446 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Common --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <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] "" |