summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2018-12-02 05:19:22 +0000
committerjao <jao@gnu.org>2018-12-02 05:19:22 +0000
commit453ad68e5b24a6dd3a2aaba8727dc6c5c0bdfc9e (patch)
treebc6d0cf0bdf970aec74f10b0d0f2cf7cac5efcda
parent61c9a5a3e86b42958e4e06a79b8156039c926177 (diff)
downloadxmobar-453ad68e5b24a6dd3a2aaba8727dc6c5c0bdfc9e.tar.gz
xmobar-453ad68e5b24a6dd3a2aaba8727dc6c5c0bdfc9e.tar.bz2
Plugins.Monitors.Common refactored into submodules
-rw-r--r--src/Xmobar/Plugins/Monitors/Common.hs541
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Output.hs203
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Parsers.hs152
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Run.hs120
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Types.hs127
-rw-r--r--xmobar.cabal4
6 files changed, 617 insertions, 530 deletions
diff --git a/src/Xmobar/Plugins/Monitors/Common.hs b/src/Xmobar/Plugins/Monitors/Common.hs
index 383a0f1..10c3c9f 100644
--- a/src/Xmobar/Plugins/Monitors/Common.hs
+++ b/src/Xmobar/Plugins/Monitors/Common.hs
@@ -13,533 +13,14 @@
--
-----------------------------------------------------------------------------
-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.Run.Commands
-
--- $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
+module Xmobar.Plugins.Monitors.Common
+ ( module Xmobar.Plugins.Monitors.Common.Types
+ , module Xmobar.Plugins.Monitors.Common.Run
+ , module Xmobar.Plugins.Monitors.Common.Output
+ , module Xmobar.Plugins.Monitors.Common.Parsers
+ ) where
+
+import Xmobar.Plugins.Monitors.Common.Types
+import Xmobar.Plugins.Monitors.Common.Run
+import Xmobar.Plugins.Monitors.Common.Output
+import Xmobar.Plugins.Monitors.Common.Parsers
diff --git a/src/Xmobar/Plugins/Monitors/Common/Output.hs b/src/Xmobar/Plugins/Monitors/Common/Output.hs
new file mode 100644
index 0000000..53c5b0f
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Common/Output.hs
@@ -0,0 +1,203 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.Plugins.Monitors.Strings
+-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: jao@gnu.org
+-- Stability: unstable
+-- Portability: portable
+-- Created: Sun Dec 02, 2018 04:25
+--
+--
+-- Utilities for formatting monitor outputs
+--
+------------------------------------------------------------------------------
+
+
+module Xmobar.Plugins.Monitors.Common.Output ( IconPattern
+ , parseIconPattern
+ , padString
+ , showWithPadding
+ , showWithColors
+ , showWithColors'
+ , showPercentWithColors
+ , showPercentsWithColors
+ , showPercentBar
+ , showVerticalBar
+ , showIconPattern
+ , showLogBar
+ , showLogVBar
+ , showLogIconPattern
+ , showWithUnits
+ , takeDigits
+ , showDigits
+ , floatToPercent
+ , parseFloat
+ , parseInt
+ , stringParser
+ ) where
+
+import Data.Char
+import Data.List (intercalate, sort)
+import qualified Data.ByteString.Lazy.Char8 as B
+import Numeric
+import Control.Monad (zipWithM)
+
+import Xmobar.Plugins.Monitors.Common.Types
+
+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
diff --git a/src/Xmobar/Plugins/Monitors/Common/Parsers.hs b/src/Xmobar/Plugins/Monitors/Common/Parsers.hs
new file mode 100644
index 0000000..4b87a10
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Common/Parsers.hs
@@ -0,0 +1,152 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.Plugins.Monitors.Parsers
+-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: jao@gnu.org
+-- Stability: unstable
+-- Portability: portable
+-- Created: Sun Dec 02, 2018 04:49
+--
+--
+-- Parsing template strings
+--
+------------------------------------------------------------------------------
+
+
+module Xmobar.Plugins.Monitors.Common.Parsers ( runP
+ , skipRestOfLine
+ , getNumbers
+ , getNumbersAsString
+ , getAllBut
+ , getAfterString
+ , skipTillString
+ , parseTemplate
+ , parseTemplate'
+ ) where
+
+import Xmobar.Plugins.Monitors.Common.Types
+
+import Control.Applicative ((<$>))
+import qualified Data.Map as Map
+import Text.ParserCombinators.Parsec
+
+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
diff --git a/src/Xmobar/Plugins/Monitors/Common/Run.hs b/src/Xmobar/Plugins/Monitors/Common/Run.hs
new file mode 100644
index 0000000..5422d71
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Common/Run.hs
@@ -0,0 +1,120 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.Plugins.Monitors.Run
+-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: jao@gnu.org
+-- Stability: unstable
+-- Portability: portable
+-- Created: Sun Dec 02, 2018 04:17
+--
+--
+-- Running a monitor
+--
+------------------------------------------------------------------------------
+
+
+module Xmobar.Plugins.Monitors.Common.Run ( runM
+ , runMD
+ , runMB
+ , runMBD
+ ) where
+
+import Control.Exception (SomeException,handle)
+import Data.List
+import Control.Monad.Reader
+import System.Console.GetOpt
+
+import Xmobar.Plugins.Monitors.Common.Types
+import Xmobar.Run.Commands (tenthSeconds)
+
+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
diff --git a/src/Xmobar/Plugins/Monitors/Common/Types.hs b/src/Xmobar/Plugins/Monitors/Common/Types.hs
new file mode 100644
index 0000000..c36a562
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Common/Types.hs
@@ -0,0 +1,127 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.Plugins.Monitors.Types
+-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: jao@gnu.org
+-- Stability: unstable
+-- Portability: portable
+-- Created: Sun Dec 02, 2018 04:31
+--
+--
+-- Type definitions and constructors for Monitors
+--
+------------------------------------------------------------------------------
+
+
+module Xmobar.Plugins.Monitors.Common.Types ( Monitor
+ , MConfig (..)
+ , Opts (..)
+ , Selector
+ , setConfigValue
+ , getConfigValue
+ , mkMConfig
+ , io
+ ) where
+
+import Data.IORef
+import Control.Monad.Reader
+
+type Monitor a = ReaderT MConfig IO a
+
+io :: IO a -> Monitor a
+io = liftIO
+
+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
diff --git a/xmobar.cabal b/xmobar.cabal
index 346de68..0fb9772 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -136,6 +136,10 @@ library
Xmobar.Plugins.Monitors,
Xmobar.Plugins.Monitors.Batt,
Xmobar.Plugins.Monitors.Common,
+ Xmobar.Plugins.Monitors.Common.Types,
+ Xmobar.Plugins.Monitors.Common.Run,
+ Xmobar.Plugins.Monitors.Common.Output,
+ Xmobar.Plugins.Monitors.Common.Parsers,
Xmobar.Plugins.Monitors.CoreCommon,
Xmobar.Plugins.Monitors.CoreTemp,
Xmobar.Plugins.Monitors.CpuFreq,