From b4f0f35ef118064bc7829b6224a896b448a37bc4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Sun, 14 Jun 2020 09:46:47 +0530 Subject: Optimize CPU monitor --- bench/main.hs | 18 +----- src/Xmobar/Plugins/Monitors/Common/Output.hs | 83 ++++++++++++++++++++++++++- src/Xmobar/Plugins/Monitors/Common/Parsers.hs | 39 +++++++++++++ src/Xmobar/Plugins/Monitors/Common/Run.hs | 21 +++++++ src/Xmobar/Plugins/Monitors/Common/Types.hs | 76 ++++++++++++++++++++++++ src/Xmobar/Plugins/Monitors/Cpu.hs | 78 ++++++++++++++++++------- 6 files changed, 279 insertions(+), 36 deletions(-) diff --git a/bench/main.hs b/bench/main.hs index 205acc8..b6f4c1a 100644 --- a/bench/main.hs +++ b/bench/main.hs @@ -18,24 +18,12 @@ main = do runMonitor :: MConfig -> Monitor a -> IO a runMonitor config r = runReaderT r config -data CpuArguments = CpuArguments { - cpuRef :: CpuDataRef, - cpuMConfig :: MConfig, - cpuArgs :: [String] - } - mkCpuArgs :: IO CpuArguments -mkCpuArgs = do - cpuRef <- newIORef [] - _ <- parseCpu cpuRef - cpuMConfig <- cpuConfig - let cpuArgs = ["-L","3","-H","50","--normal","green","--high","red"] - pure $ CpuArguments {..} - +mkCpuArgs = getArguments ["-L","3","-H","50","--normal","green","--high","red", "-t", "Cpu: %"] + -- | The action which will be benchmarked cpuAction :: CpuArguments -> IO String -cpuAction CpuArguments{..} = runMonitor cpuMConfig (doArgs cpuArgs (runCpu cpuRef) (\_ -> return True)) - +cpuAction = runCpu cpuBenchmark :: CpuArguments -> Benchmarkable cpuBenchmark cpuParams = nfIO $ cpuAction cpuParams diff --git a/src/Xmobar/Plugins/Monitors/Common/Output.hs b/src/Xmobar/Plugins/Monitors/Common/Output.hs index 7a14a74..0ac6e95 100644 --- a/src/Xmobar/Plugins/Monitors/Common/Output.hs +++ b/src/Xmobar/Plugins/Monitors/Common/Output.hs @@ -1,3 +1,5 @@ +{-#LANGUAGE RecordWildCards#-} + ------------------------------------------------------------------------------ -- | -- Module: Xmobar.Plugins.Monitors.Strings @@ -37,6 +39,10 @@ module Xmobar.Plugins.Monitors.Common.Output ( IconPattern , parseFloat , parseInt , stringParser + , pShowPercentsWithColors + , pShowPercentBar + , pShowVerticalBar + , pShowIconPattern ) where import Data.Char @@ -44,11 +50,77 @@ import Data.List (intercalate, sort) import qualified Data.ByteString.Lazy.Char8 as B import Numeric import Control.Monad (zipWithM) - +import Control.Monad.IO.Class (MonadIO(..)) import Xmobar.Plugins.Monitors.Common.Types type IconPattern = Int -> String +pShowVerticalBar :: (MonadIO m) => PureConfig -> Float -> Float -> m String +pShowVerticalBar p v x = pColorizeString p 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) + +pShowPercentsWithColors :: (MonadIO m) => PureConfig -> [Float] -> m [String] +pShowPercentsWithColors p fs = + do let fstrs = map (pFloatToPercent p) fs + temp = map (*100) fs + zipWithM (pShowWithColors p . const) fstrs temp + +pShowPercentWithColors :: (MonadIO m) => PureConfig -> Float -> m String +pShowPercentWithColors p f = fmap head $ pShowPercentsWithColors p [f] + +pShowPercentBar :: (MonadIO m) => PureConfig -> Float -> Float -> m String +pShowPercentBar p@PureConfig{..} v x = do + let bb = pBarBack + bf = pBarFore + bw = pBarWidth + let len = min bw $ round (fromIntegral bw * x) + s <- pColorizeString p v (take len $ cycle bf) + return $ s ++ take (bw - len) (cycle bb) + +pShowWithColors :: (Num a, Ord a, MonadIO m) => PureConfig -> (a -> String) -> a -> m String +pShowWithColors p f x = do + let str = pShowWithPadding p (f x) + pColorizeString p x str + +pColorizeString :: (Num a, Ord a, MonadIO m) => PureConfig -> a -> String -> m String +pColorizeString p x s = do + let h = pHigh p + l = pLow p + let col = pSetColor p s + [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low + pure $ head $ [col pHighColor | x > hh ] ++ + [col pNormalColor | x > ll ] ++ + [col pLowColor | True] + +pSetColor :: PureConfig -> String -> PSelector (Maybe String) -> String +pSetColor config str s = + do let a = getPConfigValue config s + case a of + Nothing -> str + Just c -> "" ++ str ++ "" + +pShowWithPadding :: PureConfig -> String -> String +pShowWithPadding PureConfig{..} s = let mn = pMinWidth + mx = pMaxWidth + p = pPadChars + pr = pPadRight + ellipsis = pMaxWidthEllipsis + in padString mn mx p pr ellipsis s + +pFloatToPercent :: PureConfig -> Float -> String +pFloatToPercent PureConfig{..} n = let pad = pPpad + pc = pPadChars + pr = pPadRight + up = pUseSuffix + p = showDigits 0 (n * 100) + ps = if up then "%" else "" + in padString pad pad pc pr "" p ++ ps + parseIconPattern :: String -> IconPattern parseIconPattern path = let spl = splitOnPercent path @@ -174,6 +246,15 @@ showIconPattern (Just str) x = return $ str $ convert $ 100 * x | otherwise = t where t = round val `div` 12 +pShowIconPattern :: Maybe IconPattern -> Float -> IO String +pShowIconPattern Nothing _ = return "" +pShowIconPattern (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 diff --git a/src/Xmobar/Plugins/Monitors/Common/Parsers.hs b/src/Xmobar/Plugins/Monitors/Common/Parsers.hs index 7a813e5..d814349 100644 --- a/src/Xmobar/Plugins/Monitors/Common/Parsers.hs +++ b/src/Xmobar/Plugins/Monitors/Common/Parsers.hs @@ -1,3 +1,6 @@ +{-#LANGUAGE RecordWildCards#-} +{-#LANGUAGE ScopedTypeVariables#-} + ------------------------------------------------------------------------------ -- | -- Module: Xmobar.Plugins.Monitors.Parsers @@ -25,6 +28,10 @@ module Xmobar.Plugins.Monitors.Common.Parsers ( runP , parseTemplate , parseTemplate' , parseOptsWith + , templateParser + , runExportParser + , runTemplateParser + , pureParseTemplate ) where import Xmobar.Plugins.Monitors.Common.Types @@ -34,6 +41,38 @@ import qualified Data.Map as Map import System.Console.GetOpt (ArgOrder(Permute), OptDescr, getOpt) import Text.ParserCombinators.Parsec +runTemplateParser :: PureConfig -> IO [(String, String, String)] +runTemplateParser PureConfig{..} = runP templateParser pTemplate + +runExportParser :: [String] -> IO [(String, [(String, String,String)])] +runExportParser [] = pure [] +runExportParser (x:xs) = do + s <- runP templateParser x + rem <- runExportParser xs + pure $ (x,s):rem + +pureParseTemplate :: PureConfig -> TemplateInput -> IO String +pureParseTemplate PureConfig{..} TemplateInput{..} = + do let t = pTemplate + e = pExport + w = pMaxTotalWidth + let m = let expSnds :: [([(String, String, String)], String)] = zip (map snd temAllTemplate) temMonitorValues + in Map.fromList . zip (map fst temAllTemplate) $ expSnds + s <- minCombine m temInputTemplate + let (n, s') = if w > 0 && length s > w + then trimTo (w - length pMaxTotalWidthEllipsis) "" s + else (1, s) + return $ if n > 0 then s' else s' ++ pMaxTotalWidthEllipsis + +minCombine :: Map.Map String ([(String, String, String)], String) -> [(String, String, String)] -> IO String +minCombine _ [] = return [] +minCombine m ((s,ts,ss):xs) = + do next <- minCombine m xs + str <- case Map.lookup ts m of + Nothing -> return $ "<" ++ ts ++ ">" + Just (s,r) -> let f "" = r; f n = n; in f <$> minCombine m s + pure $ s ++ str ++ ss ++ next + runP :: Parser [a] -> String -> IO [a] runP p i = case parse p "" i of diff --git a/src/Xmobar/Plugins/Monitors/Common/Run.hs b/src/Xmobar/Plugins/Monitors/Common/Run.hs index 760eab1..9b0c1b7 100644 --- a/src/Xmobar/Plugins/Monitors/Common/Run.hs +++ b/src/Xmobar/Plugins/Monitors/Common/Run.hs @@ -23,6 +23,8 @@ module Xmobar.Plugins.Monitors.Common.Run ( runM , runMLD , getArgvs , doArgs + , computePureConfig + , commonOptions ) where import Control.Exception (SomeException,handle) @@ -33,6 +35,8 @@ import System.Console.GetOpt import Xmobar.Plugins.Monitors.Common.Types import Xmobar.Run.Exec (doEveryTenthSeconds) +commonOptions = options + options :: [OptDescr Opts] options = [ @@ -66,6 +70,8 @@ getArgvs args = (_, n, [] ) -> n (_, _, errs) -> errs + + doArgs :: [String] -> ([String] -> Monitor String) -> ([String] -> Monitor Bool) @@ -140,3 +146,18 @@ runMLD args conf action looper detect cb = handle (cb . showException) loop showException :: SomeException -> String showException = ("error: "++) . show . flip asTypeOf undefined + +computePureConfig :: [String] -> IO MConfig -> IO PureConfig +computePureConfig args mconfig = do + newConfig <- getMConfig args mconfig + getPureConfig newConfig + +getMConfig :: [String] -> IO MConfig -> IO MConfig +getMConfig args mconfig = do + config <- mconfig + runReaderT (updateOptions args >> ask) config + +updateOptions :: [String] -> Monitor () +updateOptions args= case getOpt Permute options args of + (o, _, []) -> doConfigOptions o + _ -> return () diff --git a/src/Xmobar/Plugins/Monitors/Common/Types.hs b/src/Xmobar/Plugins/Monitors/Common/Types.hs index fc71da3..e8e9bfd 100644 --- a/src/Xmobar/Plugins/Monitors/Common/Types.hs +++ b/src/Xmobar/Plugins/Monitors/Common/Types.hs @@ -1,3 +1,5 @@ +{-#LANGUAGE RecordWildCards#-} + ------------------------------------------------------------------------------ -- | -- Module: Xmobar.Plugins.Monitors.Types @@ -23,6 +25,12 @@ module Xmobar.Plugins.Monitors.Common.Types ( Monitor , getConfigValue , mkMConfig , io + , PureConfig (..) + , getPConfigValue + , getConfigValue + , getPureConfig + , PSelector + , TemplateInput(..) ) where import Control.Monad.Reader (ReaderT, ask, liftIO) @@ -34,6 +42,12 @@ type Monitor a = ReaderT MConfig IO a io :: IO a -> Monitor a io = liftIO +data TemplateInput = TemplateInput { + temMonitorValues :: [String], + temInputTemplate :: [(String, String, String)], + temAllTemplate :: [(String, [(String, String, String)])] + } + data MConfig = MC { normalColor :: IORef (Maybe String) , low :: IORef Int @@ -58,14 +72,73 @@ data MConfig = , maxTotalWidthEllipsis :: IORef String } +data PureConfig = + PureConfig + { pNormalColor :: (Maybe String) + , pLow :: Int + , pLowColor :: (Maybe String) + , pHigh :: Int + , pHighColor :: (Maybe String) + , pTemplate :: String + , pExport :: [String] + , pPpad :: Int + , pDecDigits :: Int + , pMinWidth :: Int + , pMaxWidth :: Int + , pMaxWidthEllipsis :: String + , pPadChars :: String + , pPadRight :: Bool + , pBarBack :: String + , pBarFore :: String + , pBarWidth :: Int + , pUseSuffix :: Bool + , pNaString :: String + , pMaxTotalWidth :: Int + , pMaxTotalWidthEllipsis :: String + } + deriving (Eq, Ord) + +getPureConfig :: MConfig -> IO PureConfig +getPureConfig MC{..} = do + pNormalColor <- readIORef normalColor + pLow <- readIORef low + pLowColor <- readIORef lowColor + pHigh <- readIORef high + pHighColor <- readIORef highColor + pTemplate <- readIORef template + pExport <- readIORef export + pPpad <- readIORef ppad + pDecDigits <- readIORef decDigits + pMinWidth <- readIORef minWidth + pMaxWidth <- readIORef maxWidth + pMaxWidthEllipsis <- readIORef maxWidthEllipsis + pPadChars <- readIORef padChars + pPadRight <- readIORef padRight + pBarBack <- readIORef barBack + pBarFore <- readIORef barFore + pBarWidth <- readIORef barWidth + pUseSuffix <- readIORef useSuffix + pNaString <- readIORef naString + pMaxTotalWidth <- readIORef maxTotalWidth + pMaxTotalWidthEllipsis <- readIORef maxTotalWidthEllipsis + pure $ PureConfig {..} + -- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' type Selector a = MConfig -> IORef a +type PSelector a = PureConfig -> a + +psel :: PureConfig -> PSelector a -> a +psel value accessor = accessor value sel :: Selector a -> Monitor a sel s = do hs <- ask liftIO $ readIORef (s hs) +pmods :: PureConfig -> PSelector a -> (a -> a) -> a +pmods config value f = let val = value config + in f val + mods :: Selector a -> (a -> a) -> Monitor () mods s m = do v <- ask @@ -78,6 +151,9 @@ setConfigValue v s = getConfigValue :: Selector a -> Monitor a getConfigValue = sel +getPConfigValue :: PureConfig -> PSelector a -> a +getPConfigValue = psel + mkMConfig :: String -> [String] -> IO MConfig diff --git a/src/Xmobar/Plugins/Monitors/Cpu.hs b/src/Xmobar/Plugins/Monitors/Cpu.hs index 3d18da3..10881b6 100644 --- a/src/Xmobar/Plugins/Monitors/Cpu.hs +++ b/src/Xmobar/Plugins/Monitors/Cpu.hs @@ -1,3 +1,5 @@ +{-#LANGUAGE RecordWildCards#-} + ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Cpu @@ -13,12 +15,23 @@ -- ----------------------------------------------------------------------------- -module Xmobar.Plugins.Monitors.Cpu (startCpu, runCpu, cpuConfig, CpuDataRef, parseCpu) where +module Xmobar.Plugins.Monitors.Cpu + ( startCpu + , runCpu + , cpuConfig + , CpuDataRef + , CpuOpts + , CpuArguments + , parseCpu + , getArguments + ) where import Xmobar.Plugins.Monitors.Common -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Char8 as B import Data.IORef (IORef, newIORef, readIORef, writeIORef) import System.Console.GetOpt +import Xmobar.App.Timer (doEveryTenthSeconds) +import Control.Monad (void) newtype CpuOpts = CpuOpts { loadIconPattern :: Maybe IconPattern @@ -63,25 +76,50 @@ parseCpu cref = percent = map ((/ tot) . fromIntegral) dif return percent -formatCpu :: CpuOpts -> [Float] -> Monitor [String] -formatCpu _ [] = return $ replicate 8 "" -formatCpu opts xs = do +formatCpu :: CpuOpts -> [Float] -> PureConfig -> IO [String] +formatCpu _ [] _ = return $ replicate 8 "" +formatCpu opts xs p = do let t = sum $ take 3 xs - b <- showPercentBar (100 * t) t - v <- showVerticalBar (100 * t) t - d <- showIconPattern (loadIconPattern opts) t - ps <- showPercentsWithColors (t:xs) - return (b:v:d:ps) - -runCpu :: CpuDataRef -> [String] -> Monitor String -runCpu cref argv = - do c <- io (parseCpu cref) - opts <- io $ parseOptsWith options defaultOpts argv - l <- formatCpu opts c - parseTemplate l + b <- pShowPercentBar p (100 * t) t + v <- pShowVerticalBar p (100 * t) t + d <- pShowIconPattern (loadIconPattern opts) t + ps <- pShowPercentsWithColors p (t:xs) + return $ (b:v:d:ps) + +data CpuArguments = CpuArguments { + cpuDataRef :: !CpuDataRef, + cpuParams :: !PureConfig, + cpuArgs :: ![String], + cpuOpts :: !CpuOpts, + cpuInputTemplate :: ![(String, String, String)], -- [("Cpu: ","total","% "),("","user","%")] + cpuAllTemplate :: ![(String, [(String, String, String)])] -- [("bar",[]),("vbar",[]),("ipat",[]),("total",[]),...] + } + +getArguments :: [String] -> IO CpuArguments +getArguments cpuArgs = do + cpuDataRef <- newIORef [] + cpuParams <- computePureConfig cpuArgs cpuConfig + cpuInputTemplate <- runTemplateParser cpuParams + cpuAllTemplate <- runExportParser (pExport cpuParams) + nonOptions <- case getOpt Permute commonOptions cpuArgs of + (_, n, []) -> pure n + (_,_,errs) -> error $ "getArguments: " <> show errs + cpuOpts <- case getOpt Permute options nonOptions of + (o, _, []) -> pure $ foldr id defaultOpts o + (_,_,errs) -> error $ "getArguments options: " <> show errs + pure CpuArguments{..} + + +runCpu :: CpuArguments -> IO String +runCpu CpuArguments{..} = do + cpuValue <- parseCpu cpuDataRef + temMonitorValues <- formatCpu cpuOpts cpuValue cpuParams + let templateInput = TemplateInput { temInputTemplate = cpuInputTemplate, temAllTemplate = cpuAllTemplate, ..} + pureParseTemplate cpuParams templateInput startCpu :: [String] -> Int -> (String -> IO ()) -> IO () -startCpu a r cb = do +startCpu args refreshRate cb = do cref <- newIORef [] - _ <- parseCpu cref - runM a cpuConfig (runCpu cref) r cb + void $ parseCpu cref + cpuArgs <- getArguments args + doEveryTenthSeconds refreshRate (runCpu cpuArgs >>= cb) -- cgit v1.2.3