Optimize CPU monitor

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)