summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bench/main.hs18
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Output.hs83
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Parsers.hs39
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Run.hs21
-rw-r--r--src/Xmobar/Plugins/Monitors/Common/Types.hs76
-rw-r--r--src/Xmobar/Plugins/Monitors/Cpu.hs78
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: <total>%"]
+
-- | 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 -> "<fc=" ++ c ++ ">" ++ str ++ "</fc>"
+
+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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 23:49:54 +0000