xmobar-0.43: src/Xmobar/Plugins/Monitors/MultiCoreTemp.hs
-----------------------------------------------------------------------------
-- |
-- Module : Plugins.Monitors.MultiCoreTemp
-- Copyright : (c) 2019, 2020 Felix Springer
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Felix Springer <felixspringer149@gmail.com>
-- Stability : unstable
-- Portability : unportable
--
-- A core temperature monitor for Xmobar
--
-----------------------------------------------------------------------------
module Xmobar.Plugins.Monitors.MultiCoreTemp (startMultiCoreTemp) where
import Xmobar.Plugins.Monitors.Common
import Control.Monad (filterM)
import Data.Char (isDigit)
import Data.List (isPrefixOf)
import System.Console.GetOpt
import System.Directory ( doesDirectoryExist
, doesFileExist
, listDirectory
)
-- | Declare Options.
data CTOpts = CTOpts { maxIconPattern :: Maybe IconPattern
, avgIconPattern :: Maybe IconPattern
, mintemp :: Float
, maxtemp :: Float
, hwMonitorPath :: Maybe String
}
-- | Set default Options.
defaultOpts :: CTOpts
defaultOpts = CTOpts { maxIconPattern = Nothing
, avgIconPattern = Nothing
, mintemp = 0
, maxtemp = 100
, hwMonitorPath = Nothing
}
-- | Apply configured Options.
options :: [OptDescr (CTOpts -> CTOpts)]
options = [ Option [] ["max-icon-pattern"]
(ReqArg
(\ arg opts -> opts { maxIconPattern = Just $ parseIconPattern arg })
"")
""
, Option [] ["avg-icon-pattern"]
(ReqArg
(\ arg opts -> opts { avgIconPattern = Just $ parseIconPattern arg })
"")
""
, Option [] ["mintemp"]
(ReqArg
(\ arg opts -> opts { mintemp = read arg })
"")
""
, Option [] ["maxtemp"]
(ReqArg
(\ arg opts -> opts { maxtemp = read arg })
"")
""
, Option [] ["hwmon-path"]
(ReqArg
(\ arg opts -> opts { hwMonitorPath = Just arg })
"")
""
]
-- | Generate Config with a default template and options.
cTConfig :: IO MConfig
cTConfig = mkMConfig cTTemplate cTOptions
where cTTemplate = "Temp: <max>°C - <maxpc>%"
cTOptions = [ "max" , "maxpc" , "maxbar" , "maxvbar" , "maxipat"
, "avg" , "avgpc" , "avgbar" , "avgvbar" , "avgipat"
] ++ map (("core" ++) . show) [0 :: Int ..]
-- | Returns all paths in dir matching the predicate.
getMatchingPathsInDir :: FilePath -> (String -> Bool) -> IO [FilePath]
getMatchingPathsInDir dir f = do exists <- doesDirectoryExist dir
if exists
then do
files <- filter f <$> listDirectory dir
return $ fmap (\file -> dir ++ "/" ++ file) files
else return []
-- | Given a prefix, suffix, and path string, return true if the path string
-- format is prefix ++ numeric ++ suffix.
numberedPathMatcher :: String -> String -> String -> Bool
numberedPathMatcher prefix suffix path =
prefix `isPrefixOf` path
&& not (null digits)
&& afterDigits == suffix
where afterPrefix = drop (length prefix) path
digits = takeWhile isDigit afterPrefix
afterDigits = dropWhile isDigit afterPrefix
-- | Returns the first coretemp.N path found.
coretempPath :: IO (Maybe String)
coretempPath = do ps <- getMatchingPathsInDir "/sys/bus/platform/devices" coretempMatcher
xs <- filterM doesDirectoryExist ps
return (if null xs then Nothing else Just $ head xs ++ "/")
where coretempMatcher = numberedPathMatcher "coretemp." ""
-- | Returns the first hwmonN in coretemp path found or the ones in sys/class.
hwmonPaths :: IO [String]
hwmonPaths = do p <- coretempPath
let (sc, path) = case p of
Just s -> (False, s)
Nothing -> (True, "/sys/class/")
cps <- getMatchingPathsInDir (path ++ "hwmon") hwmonMatcher
ecps <- filterM doesDirectoryExist cps
return $ if sc || null ecps then ecps else [head ecps]
where hwmonMatcher = numberedPathMatcher "hwmon" ""
-- | Checks Labels, if they refer to a core and returns Strings of core-
-- temperatures.
corePaths :: Maybe String -> IO [String]
corePaths s = do ps <- case s of
Just pth -> return [pth]
_ -> hwmonPaths
cps <- concat <$> traverse (`getMatchingPathsInDir` corePathMatcher) ps
ls <- filterM doesFileExist cps
cls <- filterM isLabelFromCore ls
return $ map labelToCore cls
where corePathMatcher = numberedPathMatcher "temp" "_label"
-- | Checks if Label refers to a core.
isLabelFromCore :: FilePath -> IO Bool
isLabelFromCore p = do a <- readFile p
return $ take 4 a `elem` ["Core", "Tdie", "Tctl"]
-- | Transform a path to Label to a path to core-temperature.
labelToCore :: FilePath -> FilePath
labelToCore = (++ "input") . reverse . drop 5 . reverse
-- | Reads core-temperatures as data from the system.
cTData :: Maybe String -> IO [Float]
cTData p = do fps <- corePaths p
traverse readSingleFile fps
where readSingleFile :: FilePath -> IO Float
readSingleFile s = do a <- readFile s
return $ parseContent a
where parseContent :: String -> Float
parseContent = read . head . lines
-- | Transforms data of temperatures into temperatures of degree Celsius.
parseCT :: CTOpts -> IO [Float]
parseCT opts = do rawCTs <- cTData (hwMonitorPath opts)
let normalizedCTs = map (/ 1000) rawCTs :: [Float]
return normalizedCTs
-- | Performs calculation for maximum and average.
-- Sets up Bars and Values to be printed.
formatCT :: CTOpts -> [Float] -> Monitor [String]
formatCT opts cTs = do let CTOpts { mintemp = minT
, maxtemp = maxT } = opts
domainT = maxT - minT
maxCT = maximum cTs
avgCT = sum cTs / fromIntegral (length cTs)
calcPc t = (t - minT) / domainT
maxCTPc = calcPc maxCT
avgCTPc = calcPc avgCT
cs <- traverse showTempWithColors cTs
m <- showTempWithColors maxCT
mp <- showWithColors' (show (round (100*maxCTPc) :: Int)) maxCT
mb <- showPercentBar maxCT maxCTPc
mv <- showVerticalBar maxCT maxCTPc
mi <- showIconPattern (maxIconPattern opts) maxCTPc
a <- showTempWithColors avgCT
ap <- showWithColors' (show (round (100*avgCTPc) :: Int)) avgCT
ab <- showPercentBar avgCT avgCTPc
av <- showVerticalBar avgCT avgCTPc
ai <- showIconPattern (avgIconPattern opts) avgCTPc
let ms = [ m , mp , mb , mv , mi ]
as = [ a , ap , ab , av , ai ]
return (ms ++ as ++ cs)
where showTempWithColors :: Float -> Monitor String
showTempWithColors = showWithColors (show . (round :: Float -> Int))
runCT :: [String] -> Monitor String
runCT argv = do opts <- io $ parseOptsWith options defaultOpts argv
cTs <- io $ parseCT opts
l <- formatCT opts cTs
parseTemplate l
startMultiCoreTemp :: [String] -> Int -> (String -> IO ()) -> IO ()
startMultiCoreTemp a = runM a cTConfig runCT