summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2011-08-21 19:48:44 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2011-08-21 19:48:44 +0200
commit1fab853cb8a76eb9b7c5400924a8c53b3b095712 (patch)
tree54f20fb5987904700669d67519cc45169ae78bb7 /src
parent8afb450eb104e5335f4b1b976512842f7059142c (diff)
parent4a57c777bccbf169aa50411ecaed0af333ac6871 (diff)
downloadxmobar-1fab853cb8a76eb9b7c5400924a8c53b3b095712.tar.gz
xmobar-1fab853cb8a76eb9b7c5400924a8c53b3b095712.tar.bz2
Merge remote-tracking branch 'github/master'
Diffstat (limited to 'src')
-rw-r--r--src/Commands.hs7
-rw-r--r--src/Config.hs7
-rw-r--r--src/Plugins/DateZone.hs44
-rw-r--r--src/Plugins/Monitors/CoreCommon.hs151
-rw-r--r--src/Plugins/Monitors/CoreTemp.hs12
-rw-r--r--src/Plugins/Monitors/CpuFreq.hs18
-rw-r--r--src/Plugins/Monitors/Top.hs1
7 files changed, 180 insertions, 60 deletions
diff --git a/src/Commands.hs b/src/Commands.hs
index 38d0aed..1bfbb94 100644
--- a/src/Commands.hs
+++ b/src/Commands.hs
@@ -75,8 +75,7 @@ instance Exec Command where
-- is not possible to set a thread delay grater than about 45 minutes.
-- With a little recursion we solve the problem.
tenthSeconds :: Int -> IO ()
-tenthSeconds s | s >= x = do threadDelay y
- tenthSeconds (x - s)
+tenthSeconds s | s >= x = do threadDelay (x * 100000)
+ tenthSeconds (s - x)
| otherwise = threadDelay (s * 100000)
- where y = maxBound :: Int
- x = y `div` 100000
+ where x = (maxBound :: Int) `div` 100000
diff --git a/src/Config.hs b/src/Config.hs
index 6eb55a0..3184023 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -38,6 +38,10 @@ import Plugins.Mail
import Plugins.MBox
#endif
+#ifdef DATEZONE
+import Plugins.DateZone
+#endif
+
-- $config
-- Configuration data type and default configuration
@@ -112,5 +116,8 @@ runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: CommandReader
#ifdef INOTIFY
Mail :*: MBox :*:
#endif
+#ifdef DATEZONE
+ DateZone :*:
+#endif
()
runnableTypes = undefined
diff --git a/src/Plugins/DateZone.hs b/src/Plugins/DateZone.hs
new file mode 100644
index 0000000..4d5ce6a
--- /dev/null
+++ b/src/Plugins/DateZone.hs
@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.DateZone
+-- Copyright : (c) Martin Perner
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Martin Perner <martin@perner.cc>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A date plugin with localization support for Xmobar
+--
+-- Based on Plugins.Date
+--
+-- Usage example: in template put
+--
+-- > Run DateZone "%H:%M:%S" "utcDate" "UTC" 10
+--
+-----------------------------------------------------------------------------
+
+module Plugins.DateZone (DateZone(..)) where
+
+import Plugins
+
+import System.Locale
+
+import Data.Time.LocalTime
+import Data.Time.Format
+import Data.Time.LocalTime.TimeZone.Olson
+import Data.Time.LocalTime.TimeZone.Series
+
+data DateZone = DateZone String String String Int
+ deriving (Read, Show)
+
+instance Exec DateZone where
+ alias (DateZone _ a _ _) = a
+ run (DateZone f _ z _) = date f z
+ rate (DateZone _ _ _ r) = r
+
+date :: String -> String -> IO String
+date format zone = do
+ timeZone <- getTimeZoneSeriesFromOlsonFile ("/usr/share/zoneinfo/" ++ zone)
+ zonedTime <- getZonedTime
+ return $ formatTime defaultTimeLocale format $ utcToLocalTime' timeZone $ zonedTimeToUTC zonedTime
diff --git a/src/Plugins/Monitors/CoreCommon.hs b/src/Plugins/Monitors/CoreCommon.hs
index 80e7700..e508f7d 100644
--- a/src/Plugins/Monitors/CoreCommon.hs
+++ b/src/Plugins/Monitors/CoreCommon.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE PatternGuards #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Plugins.Monitors.CoreCommon
@@ -14,46 +16,119 @@
module Plugins.Monitors.CoreCommon where
+import Control.Applicative
+import Control.Monad
+import Data.Char hiding (Space)
+import Data.Function
+import Data.List
+import Data.Maybe
import Plugins.Monitors.Common
-import System.Posix.Files (fileExist)
-import System.IO (withFile, IOMode(ReadMode), hGetLine)
import System.Directory
-import Data.Char (isDigit)
-import Data.List (isPrefixOf)
--- |
--- Function checks the existence of first file specified by pattern and if the
--- file doesn't exists failure message is shown, otherwise the data retrieval
--- is performed.
-checkedDataRetrieval :: (Num a, Ord a, Show a) =>
- String -> String -> String -> String -> (Double -> a)
- -> (a -> String) -> Monitor String
-checkedDataRetrieval failureMessage dir file pattern trans fmt = do
- exists <- io $ fileExist $ concat [dir, "/", pattern, "0/", file]
- case exists of
- False -> return failureMessage
- True -> retrieveData dir file pattern trans fmt
+checkedDataRetrieval :: (Ord a, Num a)
+ => String -> [String] -> Maybe (String, String -> Int)
+ -> (Double -> a) -> (a -> String) -> Monitor String
+checkedDataRetrieval msg path lbl trans fmt = liftM (maybe msg id) $
+ retrieveData path lbl trans fmt
--- |
--- Function retrieves data from files in directory dir specified by
--- pattern. String values are converted to double and 'trans' applied
--- to each one. Final array is processed by template parser function
--- and returned as monitor string.
-retrieveData :: (Num a, Ord a, Show a) =>
- String -> String -> String -> (Double -> a) -> (a -> String) ->
- Monitor String
-retrieveData dir file pattern trans fmt = do
- count <- io $ dirCount dir pattern
- contents <- io $ mapM getGuts $ files count
- values <- mapM (showWithColors fmt) $ map conversion contents
- parseTemplate values
- where
- getGuts f = withFile f ReadMode hGetLine
- dirCount path str = getDirectoryContents path
- >>= return . length
- . filter (\s -> str `isPrefixOf` s
- && isDigit (last s))
- files count = map (\i -> concat [dir, "/", pattern, show i, "/", file])
- [0 .. count - 1]
- conversion = trans . (read :: String -> Double)
+retrieveData :: (Ord a, Num a)
+ => [String] -> Maybe (String, String -> Int)
+ -> (Double -> a) -> (a -> String) -> Monitor (Maybe String)
+retrieveData path lbl trans fmt = do
+ pairs <- map snd . sortBy (compare `on` fst) <$> (mapM readFiles =<< findFiles path lbl)
+ if null pairs
+ then return Nothing
+ else Just <$> ( parseTemplate
+ =<< mapM (showWithColors fmt . trans . read) pairs
+ )
+
+-- | Represents the different types of path components
+data Comp = Fix String
+ | Var [String]
+ deriving Show
+
+-- | Used to represent parts of file names separated by slashes and spaces
+data CompOrSep = Slash
+ | Space
+ | Comp String
+ deriving (Eq, Show)
+
+-- | Function to turn a list of of strings into a list of path components
+pathComponents :: [String] -> [Comp]
+pathComponents = joinComps . drop 2 . concat . intersperse [Space] . map splitParts
+ where
+ splitParts p | (l, _:r) <- break (== '/') p = (Comp l):Slash:splitParts r
+ | otherwise = [Comp p]
+
+ joinComps = uncurry joinComps' . partition isComp
+
+ isComp (Comp _) = True
+ isComp _ = False
+
+ fromComp (Comp s) = s
+ fromComp _ = error "fromComp applied to value other than (Comp _)"
+
+ joinComps' cs [] = [Fix $ fromComp $ head cs] -- cs should have only one element here,
+ -- but this keeps the pattern matching
+ -- exhaustive
+ joinComps' cs (p:ps) = let (ss, ps') = span (== p) ps
+ ct = if null ps' || (p == Space) then length ss + 1
+ else length ss
+ (ls, rs) = splitAt (ct+1) cs
+ c = case p of
+ Space -> Var $ map fromComp ls
+ Slash -> Fix $ intercalate "/" $ map fromComp ls
+ _ -> error "Should not happen"
+ in if null ps' then [c]
+ else c:joinComps' rs (drop ct ps)
+
+-- | Function to find all files matching the given path and possible label file.
+-- The path must be absolute (start with a leading slash).
+findFiles :: [String] -> Maybe (String, String -> Int)
+ -> Monitor [(String, Either Int (String, String -> Int))]
+findFiles path lbl = catMaybes
+ <$> ( mapM addLabel . zip [0..] . sort
+ =<< recFindFiles (pathComponents path) "/"
+ )
+ where
+ addLabel (i, f) = maybe (return $ Just (f, Left i))
+ (\(s, t) -> justIfExists f s t)
+ lbl
+
+ justIfExists f s t = let f' = take (length f - length s) f ++ s
+ in ifthen (Just (f, Right (f', t))) Nothing <$> (io $ doesFileExist f')
+
+ recFindFiles [] d = ifthen [d] []
+ <$> (io $ if null d then return False else doesFileExist d)
+ recFindFiles ps d = ifthen (recFindFiles' ps d) (return [])
+ =<< (io $ if null d then return True else doesDirectoryExist d)
+
+ recFindFiles' [] _ = error "Should not happen"
+ recFindFiles' (Fix p:ps) d = recFindFiles ps (d ++ "/" ++ p)
+ recFindFiles' (Var p:ps) d = concat
+ <$> ( mapM (recFindFiles ps)
+ . map (\f -> d ++ "/" ++ f)
+ . filter (matchesVar p)
+ =<< (io $ getDirectoryContents d)
+ )
+
+ matchesVar [] _ = False
+ matchesVar [v] f = v == f
+ matchesVar (v:vs) f = let f' = drop (length v) f
+ f'' = dropWhile isDigit f'
+ in and [ v `isPrefixOf` f
+ , not (null f')
+ , isDigit (head f')
+ , matchesVar vs f''
+ ]
+
+-- | Function to read the contents of the given file(s)
+readFiles :: (String, Either Int (String, String -> Int))
+ -> Monitor (Int, String)
+readFiles (fval, flbl) = (,) <$> either return (\(f, ex) -> liftM ex
+ $ io $ readFile f) flbl
+ <*> (io $ readFile fval)
+-- | Function that captures if-then-else
+ifthen :: a -> a -> Bool -> a
+ifthen thn els cnd = if cnd then thn else els \ No newline at end of file
diff --git a/src/Plugins/Monitors/CoreTemp.hs b/src/Plugins/Monitors/CoreTemp.hs
index a24b284..f7b5c95 100644
--- a/src/Plugins/Monitors/CoreTemp.hs
+++ b/src/Plugins/Monitors/CoreTemp.hs
@@ -31,11 +31,9 @@ coreTempConfig = mkMConfig
-- Function retrieves monitor string holding the core temperature
-- (or temperatures)
runCoreTemp :: [String] -> Monitor String
-runCoreTemp _ = do
- let dir = "/sys/bus/platform/devices"
- file = "temp1_input"
- pattern = "coretemp."
- divisor = 1e3 :: Double
- failureMessage = "CoreTemp: N/A"
- checkedDataRetrieval failureMessage dir file pattern (/divisor) show
+runCoreTemp _ = let path = ["/sys/bus/platform/devices/coretemp.", "/temp", "_input"]
+ lbl = Just ("_label", read . drop 5)
+ divisor = 1e3 :: Double
+ failureMessage = "CoreTemp: N/A"
+ in checkedDataRetrieval failureMessage path lbl (/divisor) show
diff --git a/src/Plugins/Monitors/CpuFreq.hs b/src/Plugins/Monitors/CpuFreq.hs
index 4f01922..dcf75e5 100644
--- a/src/Plugins/Monitors/CpuFreq.hs
+++ b/src/Plugins/Monitors/CpuFreq.hs
@@ -28,16 +28,12 @@ cpuFreqConfig = mkMConfig
-- replacements
-- |
--- Function retrieves monitor string holding the cpu frequency (or
--- frequencies)
+-- Function retrieves monitor string holding the cpu frequency (or frequencies)
runCpuFreq :: [String] -> Monitor String
-runCpuFreq _ = do
- let dir = "/sys/devices/system/cpu"
- file = "cpufreq/scaling_cur_freq"
- pattern = "cpu"
- divisor = 1e6 :: Double
- failureMessage = "CpuFreq: N/A"
- fmt x | x < 1 = show (round (x * 1000) :: Integer) ++ "MHz"
- | otherwise = showDigits 1 x ++ "GHz"
- checkedDataRetrieval failureMessage dir file pattern (/divisor) fmt
+runCpuFreq _ = let path = ["/sys/devices/system/cpu/cpu", "/cpufreq/scaling_cur_freq"]
+ divisor = 1e6 :: Double
+ failureMessage = "CpuFreq: N/A"
+ fmt x | x < 1 = (show (round (x * 1000) :: Integer)) ++ "MHz"
+ | otherwise = (show x) ++ "GHz"
+ in checkedDataRetrieval failureMessage path Nothing (/divisor) fmt
diff --git a/src/Plugins/Monitors/Top.hs b/src/Plugins/Monitors/Top.hs
index e45210c..6001164 100644
--- a/src/Plugins/Monitors/Top.hs
+++ b/src/Plugins/Monitors/Top.hs
@@ -13,6 +13,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE BangPatterns #-}
module Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where