-----------------------------------------------------------------------------
-- |
-- 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 [Char]
hwMonitorPath :: Maybe String
                     }

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

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

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

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

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

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

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

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

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

-- | Reads core-temperatures as data from the system.
cTData :: Maybe String -> IO [Float]
cTData :: Maybe [Char] -> IO [Float]
cTData Maybe [Char]
p = do [[Char]]
fps <- Maybe [Char] -> IO [[Char]]
corePaths Maybe [Char]
p
              forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [Char] -> IO Float
readSingleFile [[Char]]
fps
  where readSingleFile :: FilePath -> IO Float
        readSingleFile :: [Char] -> IO Float
readSingleFile [Char]
s = do [Char]
a <- [Char] -> IO [Char]
readFile [Char]
s
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Float
parseContent [Char]
a
          where parseContent :: String -> Float
                parseContent :: [Char] -> Float
parseContent = forall a. Read a => [Char] -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
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 [Char] -> IO [Float]
cTData (CTOpts -> Maybe [Char]
hwMonitorPath CTOpts
opts)
                  let normalizedCTs :: [Float]
normalizedCTs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Fractional a => a -> a -> a
/ Float
1000) [Float]
rawCTs :: [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 [[Char]]
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 forall a. Num a => a -> a -> a
- Float
minT
                           maxCT :: Float
maxCT = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
cTs
                           avgCT :: Float
avgCT = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Float]
cTs forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Float]
cTs)
                           calcPc :: Float -> Float
calcPc Float
t = (Float
t forall a. Num a => a -> a -> a
- Float
minT) 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

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

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

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

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

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


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

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