Merge remote-tracking branch 'github/master'

5 files changed, 170 insertions, 56 deletions

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