-----------------------------------------------------------------------------
-- |
-- 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 { CTOpts -> Maybe IconPattern
maxIconPattern :: Maybe IconPattern
                     , CTOpts -> Maybe IconPattern
avgIconPattern :: Maybe IconPattern
                     , CTOpts -> Float
mintemp :: Float
                     , CTOpts -> Float
maxtemp :: Float
                     , CTOpts -> Maybe String
hwMonitorPath :: Maybe String
                     }

-- | Set default Options.
defaultOpts :: CTOpts
defaultOpts :: CTOpts
defaultOpts = CTOpts :: Maybe IconPattern
-> Maybe IconPattern -> Float -> Float -> Maybe String -> CTOpts
CTOpts { maxIconPattern :: Maybe IconPattern
maxIconPattern = Maybe IconPattern
forall a. Maybe a
Nothing
                     , avgIconPattern :: Maybe IconPattern
avgIconPattern = Maybe IconPattern
forall a. Maybe a
Nothing
                     , mintemp :: Float
mintemp = Float
0
                     , maxtemp :: Float
maxtemp = Float
100
                     , hwMonitorPath :: Maybe String
hwMonitorPath = Maybe String
forall a. Maybe a
Nothing
                     }

-- | Apply configured Options.
options :: [OptDescr (CTOpts -> CTOpts)]
options :: [OptDescr (CTOpts -> CTOpts)]
options = [ String
-> [String]
-> ArgDescr (CTOpts -> CTOpts)
-> String
-> OptDescr (CTOpts -> CTOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"max-icon-pattern"]
              ((String -> CTOpts -> CTOpts)
-> String -> ArgDescr (CTOpts -> CTOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
                (\ String
arg CTOpts
opts -> CTOpts
opts { maxIconPattern :: Maybe IconPattern
maxIconPattern = IconPattern -> Maybe IconPattern
forall a. a -> Maybe a
Just (IconPattern -> Maybe IconPattern)
-> IconPattern -> Maybe IconPattern
forall a b. (a -> b) -> a -> b
$ String -> IconPattern
parseIconPattern String
arg })
                String
"")
              String
""
          , String
-> [String]
-> ArgDescr (CTOpts -> CTOpts)
-> String
-> OptDescr (CTOpts -> CTOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"avg-icon-pattern"]
              ((String -> CTOpts -> CTOpts)
-> String -> ArgDescr (CTOpts -> CTOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
                (\ String
arg CTOpts
opts -> CTOpts
opts { avgIconPattern :: Maybe IconPattern
avgIconPattern = IconPattern -> Maybe IconPattern
forall a. a -> Maybe a
Just (IconPattern -> Maybe IconPattern)
-> IconPattern -> Maybe IconPattern
forall a b. (a -> b) -> a -> b
$ String -> IconPattern
parseIconPattern String
arg })
                String
"")
              String
""
          , String
-> [String]
-> ArgDescr (CTOpts -> CTOpts)
-> String
-> OptDescr (CTOpts -> CTOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"mintemp"]
              ((String -> CTOpts -> CTOpts)
-> String -> ArgDescr (CTOpts -> CTOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
                (\ String
arg CTOpts
opts -> CTOpts
opts { mintemp :: Float
mintemp = String -> Float
forall a. Read a => String -> a
read String
arg })
                String
"")
              String
""
          , String
-> [String]
-> ArgDescr (CTOpts -> CTOpts)
-> String
-> OptDescr (CTOpts -> CTOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"maxtemp"]
              ((String -> CTOpts -> CTOpts)
-> String -> ArgDescr (CTOpts -> CTOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
                (\ String
arg CTOpts
opts -> CTOpts
opts { maxtemp :: Float
maxtemp = String -> Float
forall a. Read a => String -> a
read String
arg })
                String
"")
              String
""
          , String
-> [String]
-> ArgDescr (CTOpts -> CTOpts)
-> String
-> OptDescr (CTOpts -> CTOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"hwmon-path"]
              ((String -> CTOpts -> CTOpts)
-> String -> ArgDescr (CTOpts -> CTOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
                (\ String
arg CTOpts
opts -> CTOpts
opts { hwMonitorPath :: Maybe String
hwMonitorPath = String -> Maybe String
forall a. a -> Maybe a
Just String
arg })
                String
"")
              String
""
          ]

-- | Generate Config with a default template and options.
cTConfig :: IO MConfig
cTConfig :: IO MConfig
cTConfig = String -> [String] -> IO MConfig
mkMConfig String
cTTemplate [String]
cTOptions
  where cTTemplate :: String
cTTemplate = String
"Temp: <max>°C - <maxpc>%"
        cTOptions :: [String]
cTOptions = [ String
"max" , String
"maxpc" , String
"maxbar" , String
"maxvbar" , String
"maxipat"
                    , String
"avg" , String
"avgpc" , String
"avgbar" , String
"avgvbar" , String
"avgipat"
                    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ IconPattern -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"core" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> IconPattern -> IconPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IconPattern
forall a. Show a => a -> String
show) [Int
0 :: Int ..]

-- | Returns all paths in dir matching the predicate.
getMatchingPathsInDir :: FilePath -> (String -> Bool) -> IO [FilePath]
getMatchingPathsInDir :: String -> (String -> Bool) -> IO [String]
getMatchingPathsInDir String
dir String -> Bool
f = do Bool
exists <- String -> IO Bool
doesDirectoryExist String
dir
                                 if Bool
exists
                                    then do
                                      [String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
f ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
dir
                                      [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
file -> String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file) [String]
files
                                    else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
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 :: String -> String -> String -> Bool
numberedPathMatcher String
prefix String
suffix String
path =
    String
prefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
path
    Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
digits)
    Bool -> Bool -> Bool
&& String
afterDigits String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
suffix
  where afterPrefix :: String
afterPrefix = Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
path
        digits :: String
digits = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit String
afterPrefix
        afterDigits :: String
afterDigits = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isDigit String
afterPrefix

-- | Returns the first coretemp.N path found.
coretempPath :: IO (Maybe String)
coretempPath :: IO (Maybe String)
coretempPath = do [String]
ps <- String -> (String -> Bool) -> IO [String]
getMatchingPathsInDir String
"/sys/bus/platform/devices" String -> Bool
coretempMatcher
                  [String]
xs <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
ps
                  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
xs then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head [String]
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/")
  where coretempMatcher :: String -> Bool
coretempMatcher = String -> String -> String -> Bool
numberedPathMatcher String
"coretemp." String
""

-- | Returns the first hwmonN in coretemp path found or the ones in sys/class.
hwmonPaths :: IO [String]
hwmonPaths :: IO [String]
hwmonPaths = do Maybe String
p <- IO (Maybe String)
coretempPath
                let (Bool
sc, String
path) = case Maybe String
p of
                                   Just String
s -> (Bool
False, String
s)
                                   Maybe String
Nothing -> (Bool
True, String
"/sys/class/")
                [String]
cps <- String -> (String -> Bool) -> IO [String]
getMatchingPathsInDir (String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"hwmon") String -> Bool
hwmonMatcher
                [String]
ecps <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
cps
                [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ if Bool
sc Bool -> Bool -> Bool
|| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ecps then [String]
ecps else [[String] -> String
forall a. [a] -> a
head [String]
ecps]
  where hwmonMatcher :: String -> Bool
hwmonMatcher = String -> String -> String -> Bool
numberedPathMatcher String
"hwmon" String
""

-- | Checks Labels, if they refer to a core and returns Strings of core-
-- temperatures.
corePaths :: Maybe String -> IO [String]
corePaths :: Maybe String -> IO [String]
corePaths Maybe String
s = do [String]
ps <- case Maybe String
s of
                        Just String
pth -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
pth]
                        Maybe String
_ -> IO [String]
hwmonPaths
                 [String]
cps <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> (String -> Bool) -> IO [String]
`getMatchingPathsInDir` String -> Bool
corePathMatcher) [String]
ps
                 [String]
ls <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
cps
                 [String]
cls <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
isLabelFromCore [String]
ls
                 [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
labelToCore [String]
cls
  where corePathMatcher :: String -> Bool
corePathMatcher = String -> String -> String -> Bool
numberedPathMatcher String
"temp" String
"_label"

-- | Checks if Label refers to a core.
isLabelFromCore :: FilePath -> IO Bool
isLabelFromCore :: String -> IO Bool
isLabelFromCore String
p = do String
a <- String -> IO String
readFile String
p
                       Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
4 String
a String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"Core", String
"Tdie", String
"Tctl"]

-- | Transform a path to Label to a path to core-temperature.
labelToCore :: FilePath -> FilePath
labelToCore :: String -> String
labelToCore = (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"input") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
5 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse

-- | Reads core-temperatures as data from the system.
cTData :: Maybe String -> IO [Float]
cTData :: Maybe String -> IO [Float]
cTData Maybe String
p = do [String]
fps <- Maybe String -> IO [String]
corePaths Maybe String
p
              (String -> IO Float) -> [String] -> IO [Float]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO Float
readSingleFile [String]
fps
  where readSingleFile :: FilePath -> IO Float
        readSingleFile :: String -> IO Float
readSingleFile String
s = do String
a <- String -> IO String
readFile String
s
                              Float -> IO Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> IO Float) -> Float -> IO Float
forall a b. (a -> b) -> a -> b
$ String -> Float
parseContent String
a
          where parseContent :: String -> Float
                parseContent :: String -> Float
parseContent = String -> Float
forall a. Read a => String -> a
read (String -> Float) -> (String -> String) -> String -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

-- | Transforms data of temperatures into temperatures of degree Celsius.
parseCT :: CTOpts -> IO [Float]
parseCT :: CTOpts -> IO [Float]
parseCT CTOpts
opts = do [Float]
rawCTs <- Maybe String -> IO [Float]
cTData (CTOpts -> Maybe String
hwMonitorPath CTOpts
opts)
                  let normalizedCTs :: [Float]
normalizedCTs = (Float -> Float) -> [Float] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
1000) [Float]
rawCTs :: [Float]
                  [Float] -> IO [Float]
forall (m :: * -> *) a. Monad m => a -> m a
return [Float]
normalizedCTs

-- | Performs calculation for maximum and average.
-- Sets up Bars and Values to be printed.
formatCT :: CTOpts -> [Float] -> Monitor [String]
formatCT :: CTOpts -> [Float] -> Monitor [String]
formatCT CTOpts
opts [Float]
cTs = do let CTOpts { mintemp :: CTOpts -> Float
mintemp = Float
minT
                                  , maxtemp :: CTOpts -> Float
maxtemp = Float
maxT } = CTOpts
opts
                           domainT :: Float
domainT = Float
maxT Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minT
                           maxCT :: Float
maxCT = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
cTs
                           avgCT :: Float
avgCT = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Float]
cTs Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Float] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Float]
cTs)
                           calcPc :: Float -> Float
calcPc Float
t = (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minT) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
domainT
                           maxCTPc :: Float
maxCTPc = Float -> Float
calcPc Float
maxCT
                           avgCTPc :: Float
avgCTPc = Float -> Float
calcPc Float
avgCT

                       [String]
cs <- (Float -> ReaderT MConfig IO String) -> [Float] -> Monitor [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Float -> ReaderT MConfig IO String
showTempWithColors [Float]
cTs

                       String
m <- Float -> ReaderT MConfig IO String
showTempWithColors Float
maxCT
                       String
mp <- String -> Float -> ReaderT MConfig IO String
forall a.
(Num a, Ord a) =>
String -> a -> ReaderT MConfig IO String
showWithColors' (IconPattern
forall a. Show a => a -> String
show (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Float
100Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
maxCTPc) :: Int)) Float
maxCT
                       String
mb <- Float -> Float -> ReaderT MConfig IO String
showPercentBar Float
maxCT Float
maxCTPc
                       String
mv <- Float -> Float -> ReaderT MConfig IO String
showVerticalBar Float
maxCT Float
maxCTPc
                       String
mi <- Maybe IconPattern -> Float -> ReaderT MConfig IO String
showIconPattern (CTOpts -> Maybe IconPattern
maxIconPattern CTOpts
opts) Float
maxCTPc

                       String
a <- Float -> ReaderT MConfig IO String
showTempWithColors Float
avgCT
                       String
ap <- String -> Float -> ReaderT MConfig IO String
forall a.
(Num a, Ord a) =>
String -> a -> ReaderT MConfig IO String
showWithColors' (IconPattern
forall a. Show a => a -> String
show (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Float
100Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
avgCTPc) :: Int)) Float
avgCT
                       String
ab <- Float -> Float -> ReaderT MConfig IO String
showPercentBar Float
avgCT Float
avgCTPc
                       String
av <- Float -> Float -> ReaderT MConfig IO String
showVerticalBar Float
avgCT Float
avgCTPc
                       String
ai <- Maybe IconPattern -> Float -> ReaderT MConfig IO String
showIconPattern (CTOpts -> Maybe IconPattern
avgIconPattern CTOpts
opts) Float
avgCTPc

                       let ms :: [String]
ms = [ String
m , String
mp , String
mb , String
mv , String
mi ]
                           as :: [String]
as = [ String
a , String
ap , String
ab , String
av , String
ai ]

                       [String] -> Monitor [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
ms [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
as [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
cs)
  where showTempWithColors :: Float -> Monitor String
        showTempWithColors :: Float -> ReaderT MConfig IO String
showTempWithColors = (Float -> String) -> Float -> ReaderT MConfig IO String
forall a.
(Num a, Ord a) =>
(a -> String) -> a -> ReaderT MConfig IO String
showWithColors (IconPattern
forall a. Show a => a -> String
show IconPattern -> (Float -> Int) -> Float -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round :: Float -> Int))


runCT :: [String] -> Monitor String
runCT :: [String] -> ReaderT MConfig IO String
runCT [String]
argv = do CTOpts
opts <- IO CTOpts -> Monitor CTOpts
forall a. IO a -> Monitor a
io (IO CTOpts -> Monitor CTOpts) -> IO CTOpts -> Monitor CTOpts
forall a b. (a -> b) -> a -> b
$ [OptDescr (CTOpts -> CTOpts)] -> CTOpts -> [String] -> IO CTOpts
forall opts.
[OptDescr (opts -> opts)] -> opts -> [String] -> IO opts
parseOptsWith [OptDescr (CTOpts -> CTOpts)]
options CTOpts
defaultOpts [String]
argv
                [Float]
cTs <- IO [Float] -> Monitor [Float]
forall a. IO a -> Monitor a
io (IO [Float] -> Monitor [Float]) -> IO [Float] -> Monitor [Float]
forall a b. (a -> b) -> a -> b
$ CTOpts -> IO [Float]
parseCT CTOpts
opts
                [String]
l <- CTOpts -> [Float] -> Monitor [String]
formatCT CTOpts
opts [Float]
cTs
                [String] -> ReaderT MConfig IO String
parseTemplate [String]
l

startMultiCoreTemp :: [String] -> Int -> (String -> IO ()) -> IO ()
startMultiCoreTemp :: [String] -> Int -> (String -> IO ()) -> IO ()
startMultiCoreTemp [String]
a = [String]
-> IO MConfig
-> ([String] -> ReaderT MConfig IO String)
-> Int
-> (String -> IO ())
-> IO ()
runM [String]
a IO MConfig
cTConfig [String] -> ReaderT MConfig IO String
runCT