diff options
Diffstat (limited to 'src')
50 files changed, 1488 insertions, 513 deletions
diff --git a/src/Actions.hs b/src/Actions.hs index f3dc55a..cd8ecb9 100644 --- a/src/Actions.hs +++ b/src/Actions.hs @@ -14,14 +14,21 @@ module Actions (Action(..), runAction, stripActions) where import System.Process (system) import Control.Monad (void) -import Text.Regex (subRegex, mkRegex) +import Text.Regex (Regex, subRegex, mkRegex, matchRegex) +import Graphics.X11.Types (Button) -data Action = Spawn String +data Action = Spawn [Button] String deriving (Eq) runAction :: Action -> IO () -runAction (Spawn s) = void $ system (s ++ "&") +runAction (Spawn _ s) = void $ system (s ++ "&") stripActions :: String -> String -stripActions s = subRegex actionRegex s "[action=\1]\2[action]" - where actionRegex = mkRegex "<action=([^>])*>(.+?)</action>" +stripActions s = case matchRegex actionRegex s of + Nothing -> s + Just _ -> stripActions strippedOneLevel + where + strippedOneLevel = subRegex actionRegex s "[action=\\1\\2]\\3[/action]" + +actionRegex :: Regex +actionRegex = mkRegex "<action=`?([^>`]*)`?( +button=[12345]+)?>(.+)</action>" diff --git a/src/Bitmap.hs b/src/Bitmap.hs index 2045e1a..ec99ad8 100644 --- a/src/Bitmap.hs +++ b/src/Bitmap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Bitmap @@ -15,47 +16,101 @@ module Bitmap , drawBitmap , Bitmap(..)) where +import Control.Applicative((<|>)) import Control.Monad +import Control.Monad.Trans(MonadIO(..)) import Data.Map hiding (foldr, map, filter) import Graphics.X11.Xlib import System.Directory (doesFileExist) +import System.FilePath ((</>)) import System.Mem.Weak ( addFinalizer ) import ColorCache import Parsers (Widget(..)) import Actions (Action) +#ifdef XPM +import XPMFile(readXPMFile) +#endif + +#if MIN_VERSION_mtl(2, 2, 1) +import Control.Monad.Except(MonadError(..), runExceptT) + +#else +import Control.Monad.Error(MonadError(..)) +import Control.Monad.Trans.Error(ErrorT, runErrorT) + +runExceptT :: ErrorT e m a -> m (Either e a) +runExceptT = runErrorT + +#endif + +data BitmapType = Mono Pixel | Poly + data Bitmap = Bitmap { width :: Dimension , height :: Dimension , pixmap :: Pixmap + , shapePixmap :: Maybe Pixmap + , bitmapType :: BitmapType } -updateCache :: Display -> Window -> Map FilePath Bitmap -> - [[(Widget, String, Maybe Action)]] -> IO (Map FilePath Bitmap) -updateCache dpy win cache ps = do +updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> + [[(Widget, String, Maybe [Action])]] -> IO (Map FilePath Bitmap) +updateCache dpy win cache iconRoot ps = do let paths = map (\(Icon p, _, _) -> p) . concatMap (filter icons) $ ps icons (Icon _, _, _) = True icons _ = False + expandPath path@('/':_) = path + expandPath path@('.':'/':_) = path + expandPath path@('.':'.':'/':_) = path + expandPath path = iconRoot </> path go m path = if member path m then return m - else do bitmap <- loadBitmap dpy win path + else do bitmap <- loadBitmap dpy win $ expandPath path return $ maybe m (\b -> insert path b m) bitmap foldM go cache paths +readBitmapFile' + :: (MonadError String m, MonadIO m) + => Display + -> Drawable + -> String + -> m (Dimension, Dimension, Pixmap) +readBitmapFile' d w p = do + res <- liftIO $ readBitmapFile d w p + case res of + Left err -> throwError err + Right (bw, bh, bp, _, _) -> return (bw, bh, bp) + loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap) loadBitmap d w p = do exist <- doesFileExist p if exist then do - bmap <- readBitmapFile d w p - case bmap of - Right (bw, bh, bp, _, _) -> do - addFinalizer bp (freePixmap d bp) - return $ Just $ Bitmap bw bh bp + res <- runExceptT $ + tryXBM +#ifdef XPM + <|> tryXPM +#endif + case res of + Right b -> return $ Just b Left err -> do putStrLn err return Nothing else return Nothing + where tryXBM = do + (bw, bh, bp) <- readBitmapFile' d w p + liftIO $ addFinalizer bp (freePixmap d bp) + return $ Bitmap bw bh bp Nothing (Mono 1) +#ifdef XPM + tryXPM = do + (bw, bh, bp, mbpm) <- readXPMFile d w p + liftIO $ addFinalizer bp (freePixmap d bp) + case mbpm of + Nothing -> return () + Just bpm -> liftIO $ addFinalizer bpm (freePixmap d bpm) + return $ Bitmap bw bh bp mbpm Poly +#endif drawBitmap :: Display -> Drawable -> GC -> String -> String -> Position -> Position -> Bitmap -> IO () @@ -63,6 +118,13 @@ drawBitmap d p gc fc bc x y i = withColors d [fc, bc] $ \[fc', bc'] -> do let w = width i h = height i + y' = 1 + y - fromIntegral h `div` 2 setForeground d gc fc' setBackground d gc bc' - copyPlane d (pixmap i) p gc 0 0 w h x (1 + y - fromIntegral h `div` 2) 1 + case (shapePixmap i) of + Nothing -> return () + Just mask -> setClipOrigin d gc x y' >> setClipMask d gc mask + case bitmapType i of + Poly -> copyArea d (pixmap i) p gc 0 0 w h x y' + Mono pl -> copyPlane d (pixmap i) p gc 0 0 w h x y' pl + setClipMask d gc 0 diff --git a/src/ColorCache.hs b/src/ColorCache.hs index e9c5810..3f8d7b4 100644 --- a/src/ColorCache.hs +++ b/src/ColorCache.hs @@ -35,10 +35,10 @@ import Graphics.X11.Xlib data DynPixel = DynPixel Bool Pixel initColor :: Display -> String -> IO DynPixel -initColor dpy c = handle black $ (initColor' dpy c) +initColor dpy c = handle black $ initColor' dpy c where black :: SomeException -> IO DynPixel - black = (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) + black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy) type ColorCache = [(String, Color)] {-# NOINLINE colorCache #-} diff --git a/src/Commands.hs b/src/Commands.hs index a4ab5ed..e4402fc 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -62,7 +62,7 @@ instance Exec Command where start (Com prog args _ r) cb = if r > 0 then go else exec where go = exec >> tenthSeconds r >> go exec = do - (i,o,e,p) <- runInteractiveCommand (unwords (prog:args)) + (i,o,e,p) <- runInteractiveProcess prog args Nothing Nothing exit <- waitForProcess p let closeHandles = hClose o >> hClose i >> hClose e getL = handle (\(SomeException _) -> return "") diff --git a/src/Config.hs b/src/Config.hs index d785002..ee58a92 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | @@ -30,6 +30,7 @@ import Plugins.Monitors import Plugins.Date import Plugins.PipeReader import Plugins.BufferedPipeReader +import Plugins.MarqueePipeReader import Plugins.CommandReader import Plugins.StdinReader import Plugins.XMonadLog @@ -37,14 +38,10 @@ import Plugins.EWMH import Plugins.Kbd import Plugins.Locks -#ifdef INOTIFY import Plugins.Mail import Plugins.MBox -#endif -#ifdef DATEZONE import Plugins.DateZone -#endif -- $config -- Configuration data type and default configuration @@ -55,18 +52,25 @@ data Config = , bgColor :: String -- ^ Backgroud color , fgColor :: String -- ^ Default font color , position :: XPosition -- ^ Top Bottom or Static + , textOffset :: Int -- ^ Offset from top of window for text + , iconOffset :: Int -- ^ Offset from top of window for icons , border :: Border -- ^ NoBorder TopB BottomB or FullB , borderColor :: String -- ^ Border color + , borderWidth :: Int -- ^ Border width , alpha :: Int -- ^ Transparency from 0 (transparent) to 255 (opaque) , hideOnStart :: Bool -- ^ Hide (Unmap) the window on -- initialization , allDesktops :: Bool -- ^ Tell the WM to map to all desktops , overrideRedirect :: Bool -- ^ Needed for dock behaviour in some -- non-tiling WMs + , pickBroadest :: Bool -- ^ Use the broadest display + -- instead of the first one by + -- default , lowerOnStart :: Bool -- ^ lower to the bottom of the -- window stack on initialization , persistent :: Bool -- ^ Whether automatic hiding should -- be enabled or disabled + , iconRoot :: FilePath -- ^ Root folder for icons , commands :: [Runnable] -- ^ For setting the command, -- the command arguments -- and refresh rate for the programs @@ -75,7 +79,7 @@ data Config = -- commands in the output template -- (default '%') , alignSep :: String -- ^ Separators for left, center and - -- right text alignment + -- right text alignment , template :: String -- ^ The output template } deriving (Read) @@ -112,11 +116,16 @@ defaultConfig = , position = Top , border = NoBorder , borderColor = "#BFBFBF" + , borderWidth = 1 + , textOffset = -1 + , iconOffset = -1 , hideOnStart = False , lowerOnStart = True , persistent = False , allDesktops = True , overrideRedirect = True + , pickBroadest = False + , iconRoot = "." , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 , Run StdinReader] , sepChar = "%" @@ -137,11 +146,7 @@ infixr :*: -- the plugin's type to the list of types (separated by ':*:') appearing in -- this function's type signature. runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: BufferedPipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: Kbd :*: Locks :*: -#ifdef INOTIFY Mail :*: MBox :*: -#endif -#ifdef DATEZONE - DateZone :*: -#endif + DateZone :*: MarqueePipeReader :*: () runnableTypes = undefined diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index b95e59f..3f2d6f2 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -44,7 +44,7 @@ runIPC mvst = handle printException exportConnection sendSignalMethod :: TMVar SignalType -> Method sendSignalMethod mvst = method interfaceName sendSignalName - (signature_ [variantType $ toVariant $ (undefined :: SignalType)]) + (signature_ [variantType $ toVariant (undefined :: SignalType)]) (signature_ []) sendSignalMethodCall where diff --git a/src/Localize.hsc b/src/Localize.hsc index b302cd4..28f4495 100644 --- a/src/Localize.hsc +++ b/src/Localize.hsc @@ -46,7 +46,7 @@ getLangInfo item = do itemStr <- nl_langinfo item #ifdef UTF8 str <- peekCString itemStr - return $ decodeString str + return $ if (isUTF8Encoded str) then decodeString str else str #else peekCString itemStr #endif diff --git a/src/Main.hs b/src/Main.hs index f7a70ff..4146c1c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -37,7 +37,7 @@ import System.Exit import System.Environment import System.FilePath ((</>)) import System.Posix.Files -import Control.Monad (unless) +import Control.Monad (unless, liftM) import Signal (setupSignalHandler) @@ -94,25 +94,27 @@ xdgConfigDir :: IO String xdgConfigDir = do env <- getEnvironment case lookup "XDG_CONFIG_HOME" env of Just val -> return val - Nothing -> getHomeDirectory >>= return . (</> ".config") + Nothing -> liftM (</> ".config") getHomeDirectory xmobarConfigDir :: IO FilePath -xmobarConfigDir = xdgConfigDir >>= return . (</> "xmobar") +xmobarConfigDir = liftM (</> "xmobar") xdgConfigDir getXdgConfigFile :: IO FilePath -getXdgConfigFile = xmobarConfigDir >>= return . (</> "xmobarrc") +getXdgConfigFile = liftM (</> "xmobarrc") xmobarConfigDir -- | Read default configuration file or load the default config readDefaultConfig :: IO (Config,[String]) readDefaultConfig = do - xdgconf <- getXdgConfigFile - x <- io $ fileExist xdgconf + xdgConfigFile <- getXdgConfigFile + xdgConfigFileExists <- io $ fileExist xdgConfigFile home <- io $ getEnv "HOME" - let path = home ++ "/.xmobarrc" - f <- io $ fileExist path - if x then readConfig path - else if f then readConfig path - else return (defaultConfig,[]) + let defaultConfigFile = home ++ "/.xmobarrc" + defaultConfigFileExists <- io $ fileExist defaultConfigFile + if xdgConfigFileExists + then readConfig xdgConfigFile + else if defaultConfigFileExists + then readConfig defaultConfigFile + else return (defaultConfig,[]) data Opts = Help | Version @@ -129,6 +131,7 @@ data Opts = Help | SepChar String | Template String | OnScr String + | IconRoot String deriving Show options :: [OptDescr Opts] @@ -140,6 +143,8 @@ options = "The background color. Default black" , Option "F" ["fgcolor"] (ReqArg FgColor "fg color") "The foreground color. Default grey" + , Option "i" ["iconroot"] (ReqArg IconRoot "path") + "Root directory for icon pattern paths. Default '.'" , Option "a" ["alpha"] (ReqArg Alpha "alpha") "The transparency: 0 is transparent, 255 is opaque" , Option "o" ["top"] (NoArg T) "Place xmobar at the top of the screen" @@ -176,7 +181,7 @@ usage = usageInfo header options ++ footer info :: String info = "xmobar " ++ showVersion version ++ "\n (C) 2007 - 2010 Andrea Rossato " - ++ "\n (C) 2010 - 2013 Jose A Ortega Ruiz\n " + ++ "\n (C) 2010 - 2014 Jose A Ortega Ruiz\n " ++ mail ++ "\n" ++ license mail :: String @@ -189,7 +194,7 @@ license = "\nThis program is distributed in the hope that it will be useful," ++ "\nSee the License for more details." doOpts :: Config -> [Opts] -> IO Config -doOpts conf [] = +doOpts conf [] = return (conf {lowerOnStart = lowerOnStart conf && overrideRedirect conf}) doOpts conf (o:oo) = case o of @@ -205,6 +210,7 @@ doOpts conf (o:oo) = AlignSep s -> doOpts' (conf {alignSep = s}) SepChar s -> doOpts' (conf {sepChar = s}) Template s -> doOpts' (conf {template = s}) + IconRoot s -> doOpts' (conf {iconRoot = s}) OnScr n -> doOpts' (conf {position = OnScreen (read n) $ position conf}) Commands s -> case readCom 'c' s of Right x -> doOpts' (conf {commands = x}) diff --git a/src/MinXft.hsc b/src/MinXft.hsc index 327e95e..b2299af 100644 --- a/src/MinXft.hsc +++ b/src/MinXft.hsc @@ -2,7 +2,7 @@ ------------------------------------------------------------------------------ -- | -- Module: MinXft --- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2012, 2014 Jose Antonio Ortega Ruiz -- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007 -- License: BSD3-style (see LICENSE) -- @@ -26,13 +26,18 @@ module MinXft ( AXftColor , freeAXftColor , withAXftDraw , drawXftString + , drawXftString' , drawXftRect , openAXftFont , closeAXftFont , xftTxtExtents + , xftTxtExtents' , xft_ascent + , xft_ascent' , xft_descent + , xft_descent' , xft_height + , xft_height' ) where @@ -45,6 +50,7 @@ import Foreign import Foreign.C.Types import Foreign.C.String import Codec.Binary.UTF8.String as UTF8 +import Data.Char (ord) #include <X11/Xft/Xft.h> @@ -73,12 +79,21 @@ newtype AXftFont = AXftFont (Ptr AXftFont) xft_ascent :: AXftFont -> IO Int xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent} +xft_ascent' :: [AXftFont] -> IO Int +xft_ascent' = (fmap maximum) . (mapM xft_ascent) + xft_descent :: AXftFont -> IO Int xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent} +xft_descent' :: [AXftFont] -> IO Int +xft_descent' = (fmap maximum) . (mapM xft_descent) + xft_height :: AXftFont -> IO Int xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height} +xft_height' :: [AXftFont] -> IO Int +xft_height' = (fmap maximum) . (mapM xft_height) + foreign import ccall "XftTextExtentsUtf8" cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO () @@ -90,6 +105,12 @@ xftTxtExtents d f string = cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph peek cglyph +xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo +xftTxtExtents' d fs string = do + chunks <- getChunks d fs string + let (_, _, gi, _, _) = last chunks + return gi + foreign import ccall "XftFontOpenName" c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont @@ -101,6 +122,14 @@ openAXftFont dpy screen name = foreign import ccall "XftFontClose" closeAXftFont :: Display -> AXftFont -> IO () +foreign import ccall "XftCharExists" + cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool) + +xftCharExists :: Display -> AXftFont -> Char -> IO Bool +xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c) + where + bool 0 = False + bool _ = True -- Drawing fi :: (Integral a, Num b) => a -> b @@ -111,6 +140,9 @@ newtype AXftDraw = AXftDraw (Ptr AXftDraw) foreign import ccall "XftDrawCreate" c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw +foreign import ccall "XftDrawDisplay" + c_xftDrawDisplay :: AXftDraw -> IO Display + foreign import ccall "XftDrawDestroy" c_xftDrawDestroy :: AXftDraw -> IO () @@ -130,6 +162,56 @@ drawXftString d c f x y string = withArrayLen (map fi (UTF8.encode string)) (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len)) +drawXftString' :: AXftDraw -> + AXftColor -> + [AXftFont] -> + Integer -> + Integer -> + String -> IO () +drawXftString' d c fs x y string = do + display <- c_xftDrawDisplay d + chunks <- getChunks display fs string + mapM_ (\(f, s, _, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks + +-- Split string and determine fonts/offsets for individual parts +getChunks :: Display -> [AXftFont] -> [Char] -> + IO [(AXftFont, String, XGlyphInfo, Integer, Integer)] +getChunks disp fts str = do + chunks <- getFonts disp fts str + getOffsets (XGlyphInfo 0 0 0 0 0 0) chunks + where + -- Split string and determine fonts for individual parts + getFonts _ [] _ = return [] + getFonts _ _ [] = return [] + getFonts _ [ft] s = return [(ft, s)] + getFonts d fonts@(ft:_) s = do + -- Determine which glyph can be rendered by current font + glyphs <- mapM (xftCharExists d ft) s + -- Split string into parts that can/cannot be rendered + let splits = split (runs glyphs) s + -- Determine which font to render each chunk with + concat `fmap` mapM (getFont d fonts) splits + + -- Determine fonts for substrings + getFont _ [] _ = return [] + getFont _ [ft] (_, s) = return [(ft, s)] -- Last font, use it + getFont _ (ft:_) (True, s) = return [(ft, s)] -- Current font can render this substring + getFont d (_:fs) (False, s) = getFonts d fs s -- Fallback to next font + + -- Helpers + runs [] = [] + runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t + split [] _ = [] + split ((x, c):xs) s = let (h, t) = splitAt c s in (x, h) : split xs t + + -- Determine coordinates for chunks using extents + getOffsets _ [] = return [] + getOffsets (XGlyphInfo _ _ x y xo yo) ((f, s):chunks) = do + (XGlyphInfo w' h' _ _ xo' yo') <- xftTxtExtents disp f s + let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo') + rest <- getOffsets gi chunks + return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : rest + foreign import ccall "XftDrawRect" cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO () diff --git a/src/Parsers.hs b/src/Parsers.hs index a5869ef..d2fa1bf 100644 --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Xmobar.Parsers @@ -25,16 +25,18 @@ import Runnable import Commands import Actions +import Control.Monad (guard, mzero, liftM) import qualified Data.Map as Map import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Perm +import Graphics.X11.Types (Button) data Widget = Icon String | Text String type ColorString = String -- | Runs the string parser -parseString :: Config -> String -> IO [(Widget, ColorString, Maybe Action)] +parseString :: Config -> String -> IO [(Widget, ColorString, Maybe [Action])] parseString c s = case parse (stringParser (fgColor c) Nothing) "" s of Left _ -> return [(Text $ "Could not parse string: " ++ s @@ -42,15 +44,24 @@ parseString c s = , Nothing)] Right x -> return (concat x) +allParsers :: ColorString + -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] +allParsers c a = + textParser c a + <|> try (iconParser c a) + <|> try (rawParser c a) + <|> try (actionParser c a) + <|> colorParser a + -- | Gets the string and combines the needed parsers -stringParser :: String -> Maybe Action - -> Parser [[(Widget, ColorString, Maybe Action)]] -stringParser c a = manyTill (textParser c a <|> try (iconParser c a) <|> - try (actionParser c) <|> colorParser a) eof +stringParser :: String -> Maybe [Action] + -> Parser [[(Widget, ColorString, Maybe [Action])]] +stringParser c a = manyTill (allParsers c a) eof -- | Parses a maximal string without color markup. -textParser :: String -> Maybe Action - -> Parser [(Widget, ColorString, Maybe Action)] +textParser :: String -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] textParser c a = do s <- many1 $ noneOf "<" <|> try (notFollowedBy' (char '<') @@ -58,9 +69,29 @@ textParser c a = do s <- many1 $ try (string "action=") <|> try (string "/action>") <|> try (string "icon=") <|> + try (string "raw=") <|> string "/fc>")) return [(Text s, c, a)] +-- | Parse a "raw" tag, which we use to prevent other tags from creeping in. +-- The format here is net-string-esque: a literal "<raw=" followed by a +-- string of digits (base 10) denoting the length of the raw string, +-- a literal ":" as digit-string-terminator, the raw string itself, and +-- then a literal "/>". +rawParser :: ColorString + -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] +rawParser c a = do + string "<raw=" + lenstr <- many1 digit + char ':' + case reads lenstr of + [(len,[])] -> do + guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) + s <- count (fromIntegral len) anyChar + string "/>" + return [(Text s, c, a)] + _ -> mzero -- | Wrapper for notFollowedBy that returns the result of the first parser. -- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy @@ -70,28 +101,35 @@ notFollowedBy' p e = do x <- p notFollowedBy $ try (e >> return '*') return x -iconParser :: String -> Maybe Action - -> Parser [(Widget, ColorString, Maybe Action)] +iconParser :: String -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] iconParser c a = do string "<icon=" i <- manyTill (noneOf ">") (try (string "/>")) return [(Icon i, c, a)] -actionParser :: String -> Parser [(Widget, ColorString, Maybe Action)] -actionParser c = do - a <- between (string "<action=") (string ">") (many1 (noneOf ">")) - let a' = Just (Spawn a) - s <- manyTill (try (textParser c a') <|> try (iconParser c a') <|> - try (colorParser a') <|> actionParser c) - (try $ string "</action>") +actionParser :: String -> Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])] +actionParser c act = do + string "<action=" + command <- choice [between (char '`') (char '`') (many1 (noneOf "`")), + many1 (noneOf ">")] + buttons <- (char '>' >> return "1") <|> (space >> spaces >> + between (string "button=") (string ">") (many1 (oneOf "12345"))) + let a = Spawn (toButtons buttons) command + a' = case act of + Nothing -> Just [a] + Just act' -> Just $ a : act' + s <- manyTill (allParsers c a') (try $ string "</action>") return (concat s) +toButtons :: String -> [Button] +toButtons = map (\x -> read [x]) + -- | Parsers a string wrapped in a color specification. -colorParser :: Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +colorParser :: Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])] colorParser a = do c <- between (string "<fc=") (string ">") colors - s <- manyTill (try (textParser c a) <|> try (iconParser c a) <|> - try (colorParser a) <|> actionParser c) (try $ string "</fc>") + s <- manyTill (allParsers c a) (try $ string "</fc>") return (concat s) -- | Parses a color specification (hex or named) @@ -142,9 +180,6 @@ stripComments :: String -> String stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else "" - strip m ('\\':xss) = case xss of - '\\':xs -> '\\' : strip m xs - _ -> strip m $ drop 1 xss strip m ('"':xs) = '"': strip (not m) xs strip m (x:xs) = x : strip m xs strip _ [] = [] @@ -164,14 +199,19 @@ parseConfig = runParser parseConf fields "Config" . stripComments perms = permute $ Config <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition - <|?> pBorder <|?> pBdColor <|?> pAlpha <|?> pHideOnStart <|?> pAllDesktops - <|?> pOverrideRedirect <|?> pLowerOnStart <|?> pPersistent + <|?> pTextOffset <|?> pIconOffset <|?> pBorder + <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart + <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest + <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate + fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" , "border", "borderColor" ,"template", "position" - , "allDesktops", "overrideRedirect" - , "hideOnStart", "lowerOnStart", "persistent", "commands" + , "textOffset", "iconOffset" + , "allDesktops", "overrideRedirect", "pickBroadest" + , "hideOnStart", "lowerOnStart", "persistent", "iconRoot" + , "alpha", "commands" ] pFont = strField font "font" @@ -182,14 +222,19 @@ parseConfig = runParser parseConf fields "Config" . stripComments pAlignSep = strField alignSep "alignSep" pTemplate = strField template "template" - pAlpha = readField alpha "alpha" + pTextOffset = readField textOffset "textOffset" + pIconOffset = readField iconOffset "iconOffset" pPosition = readField position "position" pHideOnStart = readField hideOnStart "hideOnStart" pLowerOnStart = readField lowerOnStart "lowerOnStart" pPersistent = readField persistent "persistent" pBorder = readField border "border" + pBdWidth = readField borderWidth "borderWidth" pAllDesktops = readField allDesktops "allDesktops" pOverrideRedirect = readField overrideRedirect "overrideRedirect" + pPickBroadest = readField pickBroadest "pickBroadest" + pIconRoot = readField iconRoot "iconRoot" + pAlpha = readField alpha "alpha" pCommands = field commands "commands" readCommands @@ -209,11 +254,17 @@ parseConfig = runParser parseConf fields "Config" . stripComments readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]" - strField e n = field e n . between (strDel "start" n) (strDel "end" n) . - many $ noneOf "\"\n\r" - strDel t n = char '"' <?> strErr t n - strErr t n = "the " ++ t ++ " of the string field " ++ n ++ - " - a double quote (\")." + strField e n = field e n strMulti + + strMulti = scan '"' + where + scan lead = do + spaces + char lead + s <- manyTill anyChar (rowCont <|> unescQuote) + (char '"' >> return s) <|> liftM (s ++) (scan '\\') + rowCont = try $ char '\\' >> string "\n" + unescQuote = lookAhead (noneOf "\\") >> lookAhead (string "\"") wrapSkip x = many space >> x >>= \r -> many space >> return r sepEndSpc = mapM_ (wrapSkip . try . string) diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index a2ea2a3..9a7266e 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -14,7 +14,7 @@ module Plugins.BufferedPipeReader where -import Control.Monad(forM_, when) +import Control.Monad(forM_, when, void) import Control.Concurrent import Control.Concurrent.STM import System.IO @@ -66,7 +66,7 @@ instance Exec BufferedPipeReader where where sfork :: IO () -> IO () - sfork f = forkIO f >> return () + sfork f = void (forkIO f) update :: IO (Int, Bool, String, TVar Bool) update = atomically $ do diff --git a/src/Plugins/Date.hs b/src/Plugins/Date.hs index 3caad30..a263536 100644 --- a/src/Plugins/Date.hs +++ b/src/Plugins/Date.hs @@ -21,6 +21,7 @@ module Plugins.Date (Date(..)) where import Plugins import System.Locale +import Control.Monad (liftM) import Data.Time data Date = Date String String Int @@ -32,4 +33,4 @@ instance Exec Date where rate (Date _ _ r) = r date :: String -> IO String -date format = getZonedTime >>= return . formatTime defaultTimeLocale format +date format = liftM (formatTime defaultTimeLocale format) getZonedTime diff --git a/src/Plugins/DateZone.hs b/src/Plugins/DateZone.hs index 79596c9..f1737fb 100644 --- a/src/Plugins/DateZone.hs +++ b/src/Plugins/DateZone.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} ----------------------------------------------------------------------------- -- | @@ -23,30 +24,37 @@ module Plugins.DateZone (DateZone(..)) where import Plugins -import Localize +#ifdef DATEZONE import Control.Concurrent.STM +import System.IO.Unsafe + +import Localize import Data.Time.LocalTime import Data.Time.Format import Data.Time.LocalTime.TimeZone.Olson import Data.Time.LocalTime.TimeZone.Series -import System.IO.Unsafe import System.Locale (TimeLocale) +#else +import System.IO +import Plugins.Date +#endif -{-# NOINLINE localeLock #-} --- ensures that only one plugin instance sets the locale -localeLock :: TMVar Bool -localeLock = unsafePerformIO (newTMVarIO False) - data DateZone = DateZone String String String String Int deriving (Read, Show) instance Exec DateZone where alias (DateZone _ _ _ a _) = a +#ifndef DATEZONE + start (DateZone f _ _ a r) cb = do + hPutStrLn stderr $ "Warning: DateZone plugin needs -fwith_datezone."++ + " Using Date plugin instead." + start (Date f a r) cb +#else start (DateZone f l z _ r) cb = do lock <- atomically $ takeTMVar localeLock setupTimeLocale l @@ -60,6 +68,11 @@ instance Exec DateZone where where go func = func >>= cb >> tenthSeconds r >> go func +{-# NOINLINE localeLock #-} +-- ensures that only one plugin instance sets the locale +localeLock :: TMVar Bool +localeLock = unsafePerformIO (newTMVarIO False) + date :: String -> TimeLocale -> IO String date format loc = getZonedTime >>= return . formatTime loc format @@ -67,3 +80,4 @@ dateZone :: String -> TimeLocale -> TimeZoneSeries -> IO String dateZone format loc timeZone = getZonedTime >>= return . formatTime loc format . utcToLocalTime' timeZone . zonedTimeToUTC -- zonedTime <- getZonedTime -- return $ formatTime loc format $ utcToLocalTime' timeZone $ zonedTimeToUTC zonedTime +#endif diff --git a/src/Plugins/EWMH.hs b/src/Plugins/EWMH.hs index d5b70cb..5f1c0c4 100644 --- a/src/Plugins/EWMH.hs +++ b/src/Plugins/EWMH.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -w #-} -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, NamedFieldPuns, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | @@ -58,7 +58,7 @@ instance Exec EWMH where liftIO $ nextEvent' d ep e <- liftIO $ getEvent ep case e of - PropertyEvent { ev_atom = a, ev_window = w } -> do + PropertyEvent { ev_atom = a, ev_window = w } -> case lookup a handlers' of Just f -> f w _ -> return () @@ -95,7 +95,7 @@ fmt e (Workspaces opts) = sep " " attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)] nonEmptys = Set.unions . map desktops . Map.elems $ clients e -modifier :: Modifier -> (String -> String) +modifier :: Modifier -> String -> String modifier Hide = const "" modifier (Color fg bg) = \x -> concat ["<fc=", fg, if null bg then "" else "," ++ bg , ">", x, "</fc>"] @@ -227,9 +227,9 @@ updateClientList _ = do dels = Map.difference cl cl' new = Map.difference cl' cl modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'}) - mapM_ unmanage (map fst $ Map.toList dels) - mapM_ listen (map fst $ Map.toList cl') - mapM_ update (map fst $ Map.toList new) + mapM_ (unmanage . fst) (Map.toList dels) + mapM_ (listen . fst) (Map.toList cl') + mapM_ (update . fst) (Map.toList new) _ -> return () where unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0 diff --git a/src/Plugins/Kbd.hsc b/src/Plugins/Kbd.hsc index 241dde4..318effc 100644 --- a/src/Plugins/Kbd.hsc +++ b/src/Plugins/Kbd.hsc @@ -276,6 +276,9 @@ xkbUseCoreKbd = #const XkbUseCoreKbd xkbStateNotify :: CUInt xkbStateNotify = #const XkbStateNotify +xkbIndicatorStateNotify :: CUInt +xkbIndicatorStateNotify = #const XkbIndicatorStateNotify + xkbMapNotify :: CUInt xkbMapNotify = #const XkbMapNotify diff --git a/src/Plugins/Locks.hs b/src/Plugins/Locks.hs index 3c1e0a9..79b1583 100644 --- a/src/Plugins/Locks.hs +++ b/src/Plugins/Locks.hs @@ -20,6 +20,8 @@ import Data.Bits import Control.Monad import Graphics.X11.Xlib.Extras import Plugins +import Plugins.Kbd +import XUtil (nextEvent') data Locks = Locks deriving (Read, Show) @@ -30,22 +32,33 @@ locks = [ ( xK_Caps_Lock, "CAPS" ) , ( xK_Scroll_Lock, "SCROLL" ) ] +run' :: Display -> Window -> IO String +run' d root = do + modMap <- getModifierMapping d + ( _, _, _, _, _, _, _, m ) <- queryPointer d root + + ls <- filterM ( \( ks, _ ) -> do + kc <- keysymToKeycode d ks + return $ case find (elem kc . snd) modMap of + Nothing -> False + Just ( i, _ ) -> testBit m (fromIntegral i) + ) locks + + return $ unwords $ map snd ls + instance Exec Locks where alias Locks = "locks" - rate Locks = 2 - run Locks = do + start Locks cb = do d <- openDisplay "" root <- rootWindow d (defaultScreen d) + _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m - modMap <- getModifierMapping d - ( _, _, _, _, _, _, _, m ) <- queryPointer d root + allocaXEvent $ \ep -> forever $ do + cb =<< run' d root + nextEvent' d ep + getEvent ep - ls <- filterM ( \( ks, _ ) -> do - kc <- keysymToKeycode d ks - return $ case find (elem kc . snd) modMap of - Nothing -> False - Just ( i, _ ) -> testBit m (fromIntegral i) - ) locks closeDisplay d - - return $ unwords $ map snd ls + return () + where + m = xkbAllStateComponentsMask diff --git a/src/Plugins/MBox.hs b/src/Plugins/MBox.hs index c4335f7..62f9d78 100644 --- a/src/Plugins/MBox.hs +++ b/src/Plugins/MBox.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Plugins.MBox @@ -16,6 +17,7 @@ module Plugins.MBox (MBox(..)) where import Prelude import Plugins +#ifdef INOTIFY import Plugins.Utils (changeLoop, expandHome) import Control.Monad (when) @@ -57,6 +59,10 @@ parseOptions args = (o, _, []) -> return $ foldr id defaults o (_, _, errs) -> ioError . userError $ concat errs +#else +import System.IO +#endif + -- | A list of display names, paths to mbox files and display colours, -- followed by a list of options. data MBox = MBox [(String, FilePath, String)] [String] String @@ -64,8 +70,12 @@ data MBox = MBox [(String, FilePath, String)] [String] String instance Exec MBox where alias (MBox _ _ a) = a +#ifndef INOTIFY + start _ _ = + hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify" ++ + " but the MBox plugin requires it" +#else start (MBox boxes args _) cb = do - opts <- parseOptions args let showAll = oAll opts prefix = oPrefix opts @@ -109,3 +119,4 @@ handleNotification v _ = do (p, _) <- atomically $ readTVar v n <- countMails p atomically $ writeTVar v (p, n) +#endif diff --git a/src/Plugins/Mail.hs b/src/Plugins/Mail.hs index d146d17..772d1d7 100644 --- a/src/Plugins/Mail.hs +++ b/src/Plugins/Mail.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Plugins.Mail @@ -15,6 +16,7 @@ module Plugins.Mail where import Plugins +#ifdef INOTIFY import Plugins.Utils (expandHome, changeLoop) import Control.Monad @@ -27,6 +29,10 @@ import System.INotify import Data.List (isPrefixOf) import Data.Set (Set) import qualified Data.Set as S +#else +import System.IO +#endif + -- | A list of mail box names and paths to maildirs. data Mail = Mail [(String, FilePath)] String @@ -34,6 +40,11 @@ data Mail = Mail [(String, FilePath)] String instance Exec Mail where alias (Mail _ a) = a +#ifndef INOTIFY + start _ _ = + hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify," + ++ " but the Mail plugin requires it." +#else start (Mail ms _) cb = do vs <- mapM (const $ newTVarIO S.empty) ms @@ -51,9 +62,9 @@ instance Exec Mail where atomically $ modifyTVar v (S.union s) changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns -> - cb . unwords $ [m ++ ":" ++ show n - | (m, n) <- zip ts ns - , n /= 0 ] + cb . unwords $ [m ++ show n + | (m, n) <- zip ts ns + , n /= 0 ] handle :: TVar (Set String) -> Event -> IO () handle v e = atomically $ modifyTVar v $ case e of @@ -65,3 +76,4 @@ handle v e = atomically $ modifyTVar v $ case e of where delete = S.delete (filePath e) create = S.insert (filePath e) +#endif diff --git a/src/Plugins/MarqueePipeReader.hs b/src/Plugins/MarqueePipeReader.hs new file mode 100644 index 0000000..8120c84 --- /dev/null +++ b/src/Plugins/MarqueePipeReader.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.MarqueePipeReader +-- Copyright : (c) Reto Habluetzel +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from named pipes for long texts with marquee +-- +----------------------------------------------------------------------------- + +module Plugins.MarqueePipeReader where + +import System.IO (openFile, IOMode(ReadWriteMode), Handle) +import Plugins (tenthSeconds, Exec(alias, start), hGetLineSafe) +import System.Posix.Files (getFileStatus, isNamedPipe) +import Control.Concurrent(forkIO, threadDelay) +import Control.Concurrent.STM (TChan, atomically, writeTChan, tryReadTChan, newTChan) +import Control.Exception +import Control.Monad(forever, unless) + +type Length = Int -- length of the text to display +type Rate = Int -- delay in tenth seconds +type Separator = String -- if text wraps around, use separator + +data MarqueePipeReader = MarqueePipeReader String (Length, Rate, Separator) String + deriving (Read, Show) + +instance Exec MarqueePipeReader where + alias (MarqueePipeReader _ _ a) = a + start (MarqueePipeReader p (len, rate, sep) _) cb = do + let (def, pipe) = split ':' p + unless (null def) (cb def) + checkPipe pipe + h <- openFile pipe ReadWriteMode + line <- hGetLineSafe h + chan <- atomically newTChan + forkIO $ writer (toInfTxt line sep) sep len rate chan cb + forever $ pipeToChan h chan + where + split c xs | c `elem` xs = let (pre, post) = span (c /=) xs + in (pre, dropWhile (c ==) post) + | otherwise = ([], xs) + +pipeToChan :: Handle -> TChan String -> IO () +pipeToChan h chan = do + line <- hGetLineSafe h + atomically $ writeTChan chan line + +writer :: String -> Separator -> Length -> Rate -> TChan String -> (String -> IO ()) -> IO () +writer txt sep len rate chan cb = do + cb (take len txt) + mbnext <- atomically $ tryReadTChan chan + case mbnext of + Just new -> writer (toInfTxt new sep) sep len rate chan cb + Nothing -> tenthSeconds rate >> writer (drop 1 txt) sep len rate chan cb + +toInfTxt :: String -> String -> String +toInfTxt line sep = concat (repeat $ line ++ " " ++ sep ++ " ") + +checkPipe :: FilePath -> IO () +checkPipe file = handle (\(SomeException _) -> waitForPipe) $ do + status <- getFileStatus file + unless (isNamedPipe status) waitForPipe + where waitForPipe = threadDelay 1000 >> checkPipe file diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs index 9421170..bee3c06 100644 --- a/src/Plugins/Monitors.hs +++ b/src/Plugins/Monitors.hs @@ -19,7 +19,7 @@ module Plugins.Monitors where import Plugins -import Plugins.Monitors.Common (runM) +import Plugins.Monitors.Common (runM, runMD) import Plugins.Monitors.Weather import Plugins.Monitors.Net import Plugins.Monitors.Mem @@ -35,12 +35,13 @@ import Plugins.Monitors.CoreTemp import Plugins.Monitors.Disk import Plugins.Monitors.Top import Plugins.Monitors.Uptime +import Plugins.Monitors.CatInt #ifdef IWLIB import Plugins.Monitors.Wireless #endif #ifdef LIBMPD import Plugins.Monitors.MPD -import Plugins.Monitors.Common (runMB) +import Plugins.Monitors.Common (runMBD) #endif #ifdef ALSA import Plugins.Monitors.Volume @@ -69,6 +70,7 @@ data Monitors = Weather Station Args Rate | TopProc Args Rate | TopMem Args Rate | Uptime Args Rate + | CatInt Int FilePath Args Rate #ifdef IWLIB | Wireless Interface Args Rate #endif @@ -106,16 +108,17 @@ instance Exec Monitors where alias (Cpu _ _) = "cpu" alias (MultiCpu _ _) = "multicpu" alias (Battery _ _) = "battery" - alias (BatteryP _ _ _)= "battery" + alias (BatteryP {})= "battery" alias (BatteryN _ _ _ a)= a alias (Brightness _ _) = "bright" alias (CpuFreq _ _) = "cpufreq" alias (TopProc _ _) = "top" alias (TopMem _ _) = "topmem" alias (CoreTemp _ _) = "coretemp" - alias (DiskU _ _ _) = "disku" - alias (DiskIO _ _ _) = "diskio" + alias (DiskU {}) = "disku" + alias (DiskIO {}) = "diskio" alias (Uptime _ _) = "uptime" + alias (CatInt n _ _ _) = "cat" ++ show n #ifdef IWLIB alias (Wireless i _ _) = i ++ "wi" #endif @@ -136,7 +139,7 @@ instance Exec Monitors where start (MultiCpu a r) = startMultiCpu a r start (TopProc a r) = startTop a r start (TopMem a r) = runM a topMemConfig runTopMem r - start (Weather s a r) = runM (a ++ [s]) weatherConfig runWeather r + start (Weather s a r) = runMD (a ++ [s]) weatherConfig runWeather r weatherReady start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r start (ThermalZone z a r) = runM (a ++ [show z]) thermalZoneConfig runThermalZone r @@ -151,12 +154,13 @@ instance Exec Monitors where start (DiskU s a r) = runM a diskUConfig (runDiskU s) r start (DiskIO s a r) = startDiskIO s a r start (Uptime a r) = runM a uptimeConfig runUptime r + start (CatInt _ s a r) = runM a catIntConfig (runCatInt s) r #ifdef IWLIB - start (Wireless i a r) = runM (a ++ [i]) wirelessConfig runWireless r + start (Wireless i a r) = runM a wirelessConfig (runWireless i) r #endif #ifdef LIBMPD - start (MPD a r) = runM a mpdConfig runMPD r - start (AutoMPD a) = runMB a mpdConfig runMPD mpdWait + start (MPD a r) = runMD a mpdConfig runMPD r mpdReady + start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady #endif #ifdef ALSA start (Volume m c a r) = runM a volumeConfig (runVolume m c) r diff --git a/src/Plugins/Monitors/Batt.hs b/src/Plugins/Monitors/Batt.hs index 4c0232f..f7b31e4 100644 --- a/src/Plugins/Monitors/Batt.hs +++ b/src/Plugins/Monitors/Batt.hs @@ -34,6 +34,9 @@ data BattOpts = BattOpts , highThreshold :: Float , onlineFile :: FilePath , scale :: Float + , onIconPattern :: Maybe IconPattern + , offIconPattern :: Maybe IconPattern + , idleIconPattern :: Maybe IconPattern } defaultOpts :: BattOpts @@ -49,6 +52,9 @@ defaultOpts = BattOpts , highThreshold = -10 , onlineFile = "AC/online" , scale = 1e6 + , onIconPattern = Nothing + , offIconPattern = Nothing + , idleIconPattern = Nothing } options :: [OptDescr (BattOpts -> BattOpts)] @@ -64,6 +70,12 @@ options = , Option "H" ["hight"] (ReqArg (\x o -> o { highThreshold = read x }) "") "" , Option "f" ["online"] (ReqArg (\x o -> o { onlineFile = x }) "") "" , Option "s" ["scale"] (ReqArg (\x o -> o {scale = read x}) "") "" + , Option "" ["on-icon-pattern"] (ReqArg (\x o -> + o { onIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["off-icon-pattern"] (ReqArg (\x o -> + o { offIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["idle-icon-pattern"] (ReqArg (\x o -> + o { idleIconPattern = Just $ parseIconPattern x }) "") "" ] parseOpts :: [String] -> IO BattOpts @@ -72,7 +84,9 @@ parseOpts argv = (o, _, []) -> return $ foldr id defaultOpts o (_, _, errs) -> ioError . userError $ concat errs -data Result = Result Float Float Float String | NA +data Status = Charging | Discharging | Idle + +data Result = Result Float Float Float Status | NA sysDir :: FilePath sysDir = "/sys/class/power_supply" @@ -80,13 +94,14 @@ sysDir = "/sys/class/power_supply" battConfig :: IO MConfig battConfig = mkMConfig "Batt: <watts>, <left>% / <timeleft>" -- template - ["leftbar", "left", "acstatus", "timeleft", "watts"] -- replacements + ["leftbar", "leftvbar", "left", "acstatus", "timeleft", "watts", "leftipat"] -- replacements data Files = Files { fFull :: String , fNow :: String , fVoltage :: String , fCurrent :: String + , isCurrent :: Bool } | NoFiles data Battery = Battery @@ -103,20 +118,21 @@ batteryFiles :: String -> IO Files batteryFiles bat = do is_charge <- exists "charge_now" is_energy <- if is_charge then return False else exists "energy_now" - is_current <- exists "current_now" - plain <- if is_charge then exists "charge_full" else exists "energy_full" - let cf = if is_current then "current_now" else "power_now" + is_power <- exists "power_now" + plain <- exists (if is_charge then "charge_full" else "energy_full") + let cf = if is_power then "power_now" else "current_now" sf = if plain then "" else "_design" return $ case (is_charge, is_energy) of - (True, _) -> files "charge" cf sf - (_, True) -> files "energy" cf sf + (True, _) -> files "charge" cf sf is_power + (_, True) -> files "energy" cf sf is_power _ -> NoFiles where prefix = sysDir </> bat exists = safeFileExist prefix - files ch cf sf = Files { fFull = prefix </> ch ++ "_full" ++ sf - , fNow = prefix </> ch ++ "_now" - , fCurrent = prefix </> cf - , fVoltage = prefix </> "voltage_now" } + files ch cf sf ip = Files { fFull = prefix </> ch ++ "_full" ++ sf + , fNow = prefix </> ch ++ "_now" + , fCurrent = prefix </> cf + , fVoltage = prefix </> "voltage_now" + , isCurrent = not ip} haveAc :: FilePath -> IO Bool haveAc f = @@ -129,9 +145,10 @@ readBattery sc files = do a <- grab $ fFull files b <- grab $ fNow files d <- grab $ fCurrent files - return $ Battery (3600 * a / sc) -- wattseconds - (3600 * b / sc) -- wattseconds - (d / sc) -- watts + let sc' = if isCurrent files then sc / 10 else sc + return $ Battery (3600 * a / sc') -- wattseconds + (3600 * b / sc') -- wattseconds + (d / sc') -- watts where grab f = handle onError $ withFile f ReadMode (fmap read . hGetLine) onError = const (return (-1)) :: SomeException -> IO Float @@ -147,9 +164,10 @@ readBatteries opts bfs = time = if idle then 0 else sum $ map time' bats mwatts = if idle then 1 else sign * watts time' b = (if ac then full b - now b else now b) / mwatts - acstr = if idle then idleString opts else - if ac then onString opts else offString opts - return $ if isNaN left then NA else Result left watts time acstr + acst | idle = Idle + | ac = Charging + | otherwise = Discharging + return $ if isNaN left then NA else Result left watts time acst runBatt :: [String] -> Monitor String runBatt = runBatt' ["BAT0","BAT1","BAT2"] @@ -163,24 +181,37 @@ runBatt' bfs args = do case c of Result x w t s -> do l <- fmtPercent x - let ts = [fmtTime $ floor t, fmtWatts w opts suffix d] - parseTemplate (l ++ s:ts) - NA -> return "N/A" + ws <- fmtWatts w opts suffix d + si <- getIconPattern opts s x + parseTemplate (l ++ [fmtStatus opts s, fmtTime $ floor t, ws, si]) + NA -> getConfigValue naString where fmtPercent :: Float -> Monitor [String] fmtPercent x = do let x' = minimum [1, x] p <- showPercentWithColors x' b <- showPercentBar (100 * x') x' - return [b, p] - fmtWatts x o s d = color x o $ showDigits d x ++ (if s then "W" else "") + vb <- showVerticalBar (100 * x') x' + return [b, vb, p] + fmtWatts x o s d = do + ws <- showWithPadding $ showDigits d x ++ (if s then "W" else "") + return $ color x o ws fmtTime :: Integer -> String fmtTime x = hours ++ ":" ++ if length minutes == 2 then minutes else '0' : minutes where hours = show (x `div` 3600) minutes = show ((x `mod` 3600) `div` 60) + fmtStatus opts Idle = idleString opts + fmtStatus opts Charging = onString opts + fmtStatus opts Discharging = offString opts maybeColor Nothing str = str maybeColor (Just c) str = "<fc=" ++ c ++ ">" ++ str ++ "</fc>" color x o | x >= 0 = maybeColor (posColor o) | -x >= highThreshold o = maybeColor (highWColor o) | -x >= lowThreshold o = maybeColor (mediumWColor o) | otherwise = maybeColor (lowWColor o) + getIconPattern opts status x = do + let x' = minimum [1, x] + case status of + Idle -> showIconPattern (idleIconPattern opts) x' + Charging -> showIconPattern (onIconPattern opts) x' + Discharging -> showIconPattern (offIconPattern opts) x' diff --git a/src/Plugins/Monitors/Bright.hs b/src/Plugins/Monitors/Bright.hs index 0679ab8..cb510f6 100644 --- a/src/Plugins/Monitors/Bright.hs +++ b/src/Plugins/Monitors/Bright.hs @@ -14,9 +14,9 @@ module Plugins.Monitors.Bright (brightConfig, runBright) where +import Control.Applicative ((<$>)) import Control.Exception (SomeException, handle) import qualified Data.ByteString.Lazy.Char8 as B -import Data.Char import System.FilePath ((</>)) import System.Posix.Files (fileExist) import System.Console.GetOpt @@ -26,18 +26,22 @@ import Plugins.Monitors.Common data BrightOpts = BrightOpts { subDir :: String , currBright :: String , maxBright :: String + , curBrightIconPattern :: Maybe IconPattern } defaultOpts :: BrightOpts defaultOpts = BrightOpts { subDir = "acpi_video0" , currBright = "actual_brightness" , maxBright = "max_brightness" + , curBrightIconPattern = Nothing } options :: [OptDescr (BrightOpts -> BrightOpts)] options = [ Option "D" ["device"] (ReqArg (\x o -> o { subDir = x }) "") "" , Option "C" ["curr"] (ReqArg (\x o -> o { currBright = x }) "") "" , Option "M" ["max"] (ReqArg (\x o -> o { maxBright = x }) "") "" + , Option "" ["brightness-icon-pattern"] (ReqArg (\x o -> + o { curBrightIconPattern = Just $ parseIconPattern x }) "") "" ] -- from Batt.hs @@ -52,7 +56,7 @@ sysDir = "/sys/class/backlight/" brightConfig :: IO MConfig brightConfig = mkMConfig "<percent>" -- template - ["hbar", "percent", "bar"] -- replacements + ["vbar", "percent", "bar", "ipat"] -- replacements data Files = Files { fCurr :: String , fMax :: String @@ -61,12 +65,12 @@ data Files = Files { fCurr :: String brightFiles :: BrightOpts -> IO Files brightFiles opts = do - is_curr <- fileExist $ (fCurr files) - is_max <- fileExist $ (fCurr files) - if is_curr && is_max then return files else return NoFiles - where prefix = sysDir </> (subDir opts) - files = Files { fCurr = prefix </> (currBright opts) - , fMax = prefix </> (maxBright opts) + is_curr <- fileExist $ fCurr files + is_max <- fileExist $ fCurr files + return (if is_curr && is_max then files else NoFiles) + where prefix = sysDir </> subDir opts + files = Files { fCurr = prefix </> currBright opts + , fMax = prefix </> maxBright opts } runBright :: [String] -> Monitor String @@ -76,30 +80,20 @@ runBright args = do c <- io $ readBright f case f of NoFiles -> return "hurz" - _ -> fmtPercent c >>= parseTemplate - where fmtPercent :: Float -> Monitor [String] - fmtPercent c = do r <- showHorizontalBar (100 * c) - s <- showPercentWithColors c - t <- showPercentBar (100 * c) c - return [r,s,t] + _ -> fmtPercent opts c >>= parseTemplate + where fmtPercent :: BrightOpts -> Float -> Monitor [String] + fmtPercent opts c = do r <- showVerticalBar (100 * c) c + s <- showPercentWithColors c + t <- showPercentBar (100 * c) c + d <- showIconPattern (curBrightIconPattern opts) c + return [r,s,t,d] readBright :: Files -> IO Float readBright NoFiles = return 0 readBright files = do - currVal<- grab $ (fCurr files) - maxVal <- grab $ (fMax files) - return $ (currVal / maxVal) - where grab f = handle handler (fmap (read . B.unpack) $ B.readFile f) + currVal<- grab $ fCurr files + maxVal <- grab $ fMax files + return (currVal / maxVal) + where grab f = handle handler (read . B.unpack <$> B.readFile f) handler = const (return 0) :: SomeException -> IO Float -showHorizontalBar :: Float -> Monitor String -showHorizontalBar x = do - return $ [convert x] - where convert :: Float -> Char - convert val - | t <= 9600 = ' ' - | t > 9608 = chr 9608 - | otherwise = chr t - where - -- we scale from 0 to 100, we have 8 slots (9 elements), 100/8 = 12 - t = 9600 + ((round val) `div` 12) diff --git a/src/Plugins/Monitors/CatInt.hs b/src/Plugins/Monitors/CatInt.hs new file mode 100644 index 0000000..aacbd71 --- /dev/null +++ b/src/Plugins/Monitors/CatInt.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CatInt +-- Copyright : (c) Nathaniel Wesley Filardo +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Nathaniel Wesley Filardo +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.CatInt where + +import Plugins.Monitors.Common +import Plugins.Monitors.CoreCommon + +catIntConfig :: IO MConfig +catIntConfig = mkMConfig "<v>" ["v"] + +runCatInt :: FilePath -> [String] -> Monitor String +runCatInt p _ = + let failureMessage = "Cannot read: " ++ show p + fmt x = show (truncate x :: Int) + in checkedDataRetrieval failureMessage [[p]] Nothing id fmt diff --git a/src/Plugins/Monitors/Common.hs b/src/Plugins/Monitors/Common.hs index 973c5f9..7d11258 100644 --- a/src/Plugins/Monitors/Common.hs +++ b/src/Plugins/Monitors/Common.hs @@ -23,7 +23,9 @@ module Plugins.Monitors.Common ( , getConfigValue , mkMConfig , runM + , runMD , runMB + , runMBD , io -- * Parsers -- $parsers @@ -38,6 +40,8 @@ module Plugins.Monitors.Common ( , parseTemplate' -- ** String Manipulation -- $strings + , IconPattern + , parseIconPattern , padString , showWithPadding , showWithColors @@ -45,7 +49,11 @@ module Plugins.Monitors.Common ( , showPercentWithColors , showPercentsWithColors , showPercentBar + , showVerticalBar + , showIconPattern , showLogBar + , showLogVBar + , showLogIconPattern , showWithUnits , takeDigits , showDigits @@ -56,11 +64,13 @@ module Plugins.Monitors.Common ( ) where +import Control.Applicative ((<$>)) import Control.Monad.Reader import qualified Data.ByteString.Lazy.Char8 as B import Data.IORef import qualified Data.Map as Map import Data.List +import Data.Char import Numeric import Text.ParserCombinators.Parsec import System.Console.GetOpt @@ -89,6 +99,7 @@ data MConfig = , barFore :: IORef String , barWidth :: IORef Int , useSuffix :: IORef Bool + , naString :: IORef String } -- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' @@ -106,7 +117,7 @@ mods s m = setConfigValue :: a -> Selector a -> Monitor () setConfigValue v s = - mods s (\_ -> v) + mods s (const v) getConfigValue :: Selector a -> Monitor a getConfigValue = sel @@ -132,7 +143,8 @@ mkMConfig tmpl exprts = bf <- newIORef "#" bw <- newIORef 10 up <- newIORef False - return $ MC nc l lc h hc t e p d mn mx pc pr bb bf bw up + na <- newIORef "N/A" + return $ MC nc l lc h hc t e p d mn mx pc pr bb bf bw up na data Opts = HighColor String | NormalColor String @@ -151,34 +163,39 @@ data Opts = HighColor String | BarFore String | BarWidth String | UseSuffix String + | NAString String options :: [OptDescr Opts] options = [ - Option "H" ["High"] (ReqArg High "number") "The high threshold" - , Option "L" ["Low"] (ReqArg Low "number") "The low threshold" - , Option "h" ["high"] (ReqArg HighColor "color number") "Color for the high threshold: ex \"#FF0000\"" - , Option "n" ["normal"] (ReqArg NormalColor "color number") "Color for the normal threshold: ex \"#00FF00\"" - , Option "l" ["low"] (ReqArg LowColor "color number") "Color for the low threshold: ex \"#0000FF\"" - , Option "t" ["template"] (ReqArg Template "output template") "Output template." - , Option "S" ["suffix"] (ReqArg UseSuffix "True/False") "Use % to display percents or other suffixes." - , Option "d" ["ddigits"] (ReqArg DecDigits "decimal digits") "Number of decimal digits to display." - , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width." - , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width") "Minimum field width" - , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width") "Maximum field width" - , Option "w" ["width"] (ReqArg Width "fixed width") "Fixed field width" - , Option "c" ["padchars"] (ReqArg PadChars "padding chars") "Characters to use for padding" - , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right" - , Option "b" ["bback"] (ReqArg BarBack "bar background") "Characters used to draw bar backgrounds" - , Option "f" ["bfore"] (ReqArg BarFore "bar foreground") "Characters used to draw bar foregrounds" - , Option "W" ["bwidth"] (ReqArg BarWidth "bar width") "Bar width" + Option "H" ["High"] (ReqArg High "number") "The high threshold" + , Option "L" ["Low"] (ReqArg Low "number") "The low threshold" + , Option "h" ["high"] (ReqArg HighColor "color number") "Color for the high threshold: ex \"#FF0000\"" + , Option "n" ["normal"] (ReqArg NormalColor "color number") "Color for the normal threshold: ex \"#00FF00\"" + , Option "l" ["low"] (ReqArg LowColor "color number") "Color for the low threshold: ex \"#0000FF\"" + , Option "t" ["template"] (ReqArg Template "output template") "Output template." + , Option "S" ["suffix"] (ReqArg UseSuffix "True/False") "Use % to display percents or other suffixes." + , Option "d" ["ddigits"] (ReqArg DecDigits "decimal digits") "Number of decimal digits to display." + , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width." + , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width") "Minimum field width" + , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width") "Maximum field width" + , Option "w" ["width"] (ReqArg Width "fixed width") "Fixed field width" + , Option "c" ["padchars"] (ReqArg PadChars "padding chars") "Characters to use for padding" + , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right" + , Option "b" ["bback"] (ReqArg BarBack "bar background") "Characters used to draw bar backgrounds" + , Option "f" ["bfore"] (ReqArg BarFore "bar foreground") "Characters used to draw bar foregrounds" + , Option "W" ["bwidth"] (ReqArg BarWidth "bar width") "Bar width" + , Option "x" ["nastring"] (ReqArg NAString "N/A string") "String used when the monitor is not available" ] -doArgs :: [String] -> ([String] -> Monitor String) -> Monitor String -doArgs args action = +doArgs :: [String] -> ([String] -> Monitor String) -> ([String] -> Monitor Bool) -> Monitor String +doArgs args action detect = case getOpt Permute options args of (o, n, []) -> do doConfigOptions o - action n + ready <- detect n + if ready + then action n + else return "<Waiting...>" (_, _, errs) -> return (concat errs) doConfigOptions :: [Opts] -> Monitor () @@ -205,16 +222,25 @@ doConfigOptions (o:oo) = BarBack s -> setConfigValue s barBack BarFore s -> setConfigValue s barFore BarWidth w -> setConfigValue (nz w) barWidth - UseSuffix u -> setConfigValue (bool u) useSuffix) >> next + UseSuffix u -> setConfigValue (bool u) useSuffix + NAString s -> setConfigValue s naString) >> next runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int -> (String -> IO ()) -> IO () runM args conf action r = runMB args conf action (tenthSeconds r) -runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) - -> IO () -> (String -> IO ()) -> IO () -runMB args conf action wait cb = handle (cb . showException) loop - where ac = doArgs args action +runMD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int + -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () +runMD args conf action r = runMBD args conf action (tenthSeconds r) + +runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () + -> (String -> IO ()) -> IO () +runMB args conf action wait = runMBD args conf action wait (\_ -> return True) + +runMBD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () + -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () +runMBD args conf action wait detect cb = handle (cb . showException) loop + where ac = doArgs args action detect loop = conf >>= runReaderT ac >>= cb >> wait >> loop showException :: SomeException -> String @@ -319,13 +345,25 @@ combine :: Map.Map String String -> [(String, String, String)] -> Monitor String combine _ [] = return [] combine m ((s,ts,ss):xs) = do next <- combine m xs - let str = Map.findWithDefault err ts m - err = "<" ++ ts ++ " not found!>" - nstr <- parseTemplate' str m - return $ s ++ (if null nstr then str else nstr) ++ ss ++ next + str <- case Map.lookup ts m of + Nothing -> return $ "<" ++ ts ++ ">" + Just r -> let f "" = r; f n = n; in f <$> parseTemplate' r m + return $ s ++ str ++ ss ++ next -- $strings +type IconPattern = Int -> String + +parseIconPattern :: String -> IconPattern +parseIconPattern path = + let spl = splitOnPercent path + in \i -> concat $ intersperse (show i) spl + where splitOnPercent [] = [[]] + splitOnPercent ('%':'%':xs) = [] : splitOnPercent xs + splitOnPercent (x:xs) = + let rest = splitOnPercent xs + in (x : head rest) : tail rest + type Pos = (Int, Int) takeDigits :: Int -> Float -> Float @@ -431,8 +469,50 @@ showPercentBar v x = do s <- colorizeString v (take len $ cycle bf) return $ s ++ take (bw - len) (cycle bb) +showIconPattern :: Maybe IconPattern -> Float -> Monitor String +showIconPattern Nothing _ = return "" +showIconPattern (Just str) x = return $ str $ convert $ 100 * x + where convert val + | t <= 0 = 0 + | t > 8 = 8 + | otherwise = t + where t = round val `div` 12 + +showVerticalBar :: Float -> Float -> Monitor String +showVerticalBar v x = colorizeString v [convert $ 100 * x] + where convert :: Float -> Char + convert val + | t <= 9600 = ' ' + | t > 9608 = chr 9608 + | otherwise = chr t + where t = 9600 + (round val `div` 12) + showLogBar :: Float -> Float -> Monitor String -showLogBar f v = do +showLogBar f v = + let intConfig c = fromIntegral `fmap` getConfigValue c + in do + h <- intConfig high + l <- intConfig low + bw <- intConfig barWidth + let [ll, hh] = sort [l, h] + choose x | x == 0.0 = 0 + | x <= ll = 1 / bw + | otherwise = f + logBase 2 (x / hh) / bw + showPercentBar v $ choose v + +showLogVBar :: Float -> Float -> Monitor String +showLogVBar f v = do + h <- fromIntegral `fmap` getConfigValue high + l <- fromIntegral `fmap` getConfigValue low + bw <- fromIntegral `fmap` getConfigValue barWidth + let [ll, hh] = sort [l, h] + choose x | x == 0.0 = 0 + | x <= ll = 1 / bw + | otherwise = f + logBase 2 (x / hh) / bw + showVerticalBar v $ choose v + +showLogIconPattern :: Maybe IconPattern -> Float -> Float -> Monitor String +showLogIconPattern str f v = do h <- fromIntegral `fmap` getConfigValue high l <- fromIntegral `fmap` getConfigValue low bw <- fromIntegral `fmap` getConfigValue barWidth @@ -440,4 +520,4 @@ showLogBar f v = do choose x | x == 0.0 = 0 | x <= ll = 1 / bw | otherwise = f + logBase 2 (x / hh) / bw - showPercentBar v $ choose v + showIconPattern str $ choose v diff --git a/src/Plugins/Monitors/CoreCommon.hs b/src/Plugins/Monitors/CoreCommon.hs index c7fb7d5..943f491 100644 --- a/src/Plugins/Monitors/CoreCommon.hs +++ b/src/Plugins/Monitors/CoreCommon.hs @@ -26,16 +26,18 @@ import Plugins.Monitors.Common import System.Directory checkedDataRetrieval :: (Ord a, Num a) - => String -> [String] -> Maybe (String, String -> Int) + => String -> [[String]] -> Maybe (String, String -> Int) -> (Double -> a) -> (a -> String) -> Monitor String -checkedDataRetrieval msg path lbl trans fmt = liftM (fromMaybe msg) $ - retrieveData path lbl trans fmt +checkedDataRetrieval msg paths lbl trans fmt = + liftM (fromMaybe msg . listToMaybe . catMaybes) $ + mapM (\p -> retrieveData p lbl trans fmt) paths 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) + pairs <- map snd . sortBy (compare `on` fst) <$> + (mapM readFiles =<< findFilesAndLabel path lbl) if null pairs then return Nothing else Just <$> ( parseTemplate @@ -84,9 +86,9 @@ pathComponents = joinComps . drop 2 . intercalate [Space] . map splitParts -- | 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) +findFilesAndLabel :: [String] -> Maybe (String, String -> Int) -> Monitor [(String, Either Int (String, String -> Int))] -findFiles path lbl = catMaybes +findFilesAndLabel path lbl = catMaybes <$> ( mapM addLabel . zip [0..] . sort =<< recFindFiles (pathComponents path) "/" ) diff --git a/src/Plugins/Monitors/CoreTemp.hs b/src/Plugins/Monitors/CoreTemp.hs index 2880751..e19baf0 100644 --- a/src/Plugins/Monitors/CoreTemp.hs +++ b/src/Plugins/Monitors/CoreTemp.hs @@ -27,17 +27,19 @@ import Data.Char (isDigit) coreTempConfig :: IO MConfig coreTempConfig = mkMConfig "Temp: <core0>C" -- template - (zipWith (++) (repeat "core") (map show [0 :: Int ..])) -- available - -- replacements + (map ((++) "core" . show) [0 :: Int ..]) -- available + -- replacements -- | -- Function retrieves monitor string holding the core temperature -- (or temperatures) runCoreTemp :: [String] -> Monitor String -runCoreTemp _ = let path = ["/sys/bus/platform/devices/coretemp.", - "/temp", - "_input"] - lbl = Just ("_label", read . (dropWhile (not . isDigit))) - divisor = 1e3 :: Double - failureMessage = "CoreTemp: N/A" - in checkedDataRetrieval failureMessage path lbl (/divisor) show +runCoreTemp _ = do + dn <- getConfigValue decDigits + failureMessage <- getConfigValue naString + let path = ["/sys/bus/platform/devices/coretemp.", "/temp", "_input"] + path' = ["/sys/bus/platform/devices/coretemp.", "/hwmon/hwmon", "/temp", "_input"] + lbl = Just ("_label", read . dropWhile (not . isDigit)) + divisor = 1e3 :: Double + show' = showDigits (max 0 dn) + checkedDataRetrieval failureMessage [path, path'] lbl (/divisor) show' diff --git a/src/Plugins/Monitors/Cpu.hs b/src/Plugins/Monitors/Cpu.hs index 6627f53..7fed989 100644 --- a/src/Plugins/Monitors/Cpu.hs +++ b/src/Plugins/Monitors/Cpu.hs @@ -18,18 +18,40 @@ module Plugins.Monitors.Cpu (startCpu) where import Plugins.Monitors.Common import qualified Data.ByteString.Lazy.Char8 as B import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.Console.GetOpt + +data CpuOpts = CpuOpts + { loadIconPattern :: Maybe IconPattern + } + +defaultOpts :: CpuOpts +defaultOpts = CpuOpts + { loadIconPattern = Nothing + } + +options :: [OptDescr (CpuOpts -> CpuOpts)] +options = + [ Option "" ["load-icon-pattern"] (ReqArg (\x o -> + o { loadIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO CpuOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs cpuConfig :: IO MConfig cpuConfig = mkMConfig "Cpu: <total>%" - ["bar","total","user","nice","system","idle","iowait"] + ["bar","vbar","ipat","total","user","nice","system","idle","iowait"] -type CpuDataRef = IORef [Float] +type CpuDataRef = IORef [Int] -cpuData :: IO [Float] +cpuData :: IO [Int] cpuData = cpuParser `fmap` B.readFile "/proc/stat" -cpuParser :: B.ByteString -> [Float] +cpuParser :: B.ByteString -> [Int] cpuParser = map (read . B.unpack) . tail . B.words . head . B.lines parseCpu :: CpuDataRef -> IO [Float] @@ -38,22 +60,25 @@ parseCpu cref = b <- cpuData writeIORef cref b let dif = zipWith (-) b a - tot = foldr (+) 0 dif - percent = map (/ tot) dif + tot = fromIntegral $ sum dif + percent = map ((/ tot) . fromIntegral) dif return percent -formatCpu :: [Float] -> Monitor [String] -formatCpu [] = return $ replicate 6 "" -formatCpu xs = do +formatCpu :: CpuOpts -> [Float] -> Monitor [String] +formatCpu _ [] = return $ replicate 8 "" +formatCpu opts xs = do let t = sum $ take 3 xs b <- showPercentBar (100 * t) t + v <- showVerticalBar (100 * t) t + d <- showIconPattern (loadIconPattern opts) t ps <- showPercentsWithColors (t:xs) - return (b:ps) + return (b:v:d:ps) runCpu :: CpuDataRef -> [String] -> Monitor String -runCpu cref _ = +runCpu cref argv = do c <- io (parseCpu cref) - l <- formatCpu c + opts <- io $ parseOpts argv + l <- formatCpu opts c parseTemplate l startCpu :: [String] -> Int -> (String -> IO ()) -> IO () diff --git a/src/Plugins/Monitors/CpuFreq.hs b/src/Plugins/Monitors/CpuFreq.hs index dcf75e5..8301547 100644 --- a/src/Plugins/Monitors/CpuFreq.hs +++ b/src/Plugins/Monitors/CpuFreq.hs @@ -18,22 +18,24 @@ import Plugins.Monitors.Common import Plugins.Monitors.CoreCommon -- | --- Cpu frequency default configuration. Default template contains only one --- core frequency, user should specify custom template in order to get more --- cpu frequencies. +-- Cpu frequency default configuration. Default template contains only +-- one core frequency, user should specify custom template in order to +-- get more cpu frequencies. cpuFreqConfig :: IO MConfig -cpuFreqConfig = mkMConfig - "Freq: <cpu0>" -- template - (zipWith (++) (repeat "cpu") (map show [0 :: Int ..])) -- available - -- replacements +cpuFreqConfig = + mkMConfig "Freq: <cpu0>" (map ((++) "cpu" . show) [0 :: Int ..]) + -- | --- 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 _ = 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 - +runCpuFreq _ = do + suffix <- getConfigValue useSuffix + let path = ["/sys/devices/system/cpu/cpu", "/cpufreq/scaling_cur_freq"] + divisor = 1e6 :: Double + fmt x | x < 1 = show (round (x * 1000) :: Integer) ++ + if suffix then "MHz" else "" + | otherwise = show x ++ if suffix then "GHz" else "" + failureMessage <- getConfigValue naString + checkedDataRetrieval failureMessage [path] Nothing (/divisor) fmt diff --git a/src/Plugins/Monitors/Disk.hs b/src/Plugins/Monitors/Disk.hs index 73bd5b7..0019c1a 100644 --- a/src/Plugins/Monitors/Disk.hs +++ b/src/Plugins/Monitors/Disk.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Disk --- Copyright : (c) 2010, 2011, 2012 Jose A Ortega Ruiz +-- Copyright : (c) 2010, 2011, 2012, 2014 Jose A Ortega Ruiz -- License : BSD-style (see LICENSE) -- -- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> @@ -23,15 +23,69 @@ import Control.Exception (SomeException, handle) import Control.Monad (zipWithM) import qualified Data.ByteString.Lazy.Char8 as B import Data.List (isPrefixOf, find) -import System.Directory (canonicalizePath) +import Data.Maybe (catMaybes) +import System.Directory (canonicalizePath, doesFileExist) +import System.Console.GetOpt + +data DiskIOOpts = DiskIOOpts + { totalIconPattern :: Maybe IconPattern + , writeIconPattern :: Maybe IconPattern + , readIconPattern :: Maybe IconPattern + } + +parseDiskIOOpts :: [String] -> IO DiskIOOpts +parseDiskIOOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + where defaultOpts = DiskIOOpts + { totalIconPattern = Nothing + , writeIconPattern = Nothing + , readIconPattern = Nothing + } + options = + [ Option "" ["total-icon-pattern"] (ReqArg (\x o -> + o { totalIconPattern = Just $ parseIconPattern x}) "") "" + , Option "" ["write-icon-pattern"] (ReqArg (\x o -> + o { writeIconPattern = Just $ parseIconPattern x}) "") "" + , Option "" ["read-icon-pattern"] (ReqArg (\x o -> + o { readIconPattern = Just $ parseIconPattern x}) "") "" + ] diskIOConfig :: IO MConfig -diskIOConfig = mkMConfig "" ["total", "read", "write", - "totalbar", "readbar", "writebar"] +diskIOConfig = mkMConfig "" ["total", "read", "write" + ,"totalbar", "readbar", "writebar" + ,"totalvbar", "readvbar", "writevbar" + ,"totalipat", "readipat", "writeipat" + ] + +data DiskUOpts = DiskUOpts + { freeIconPattern :: Maybe IconPattern + , usedIconPattern :: Maybe IconPattern + } + +parseDiskUOpts :: [String] -> IO DiskUOpts +parseDiskUOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + where defaultOpts = DiskUOpts + { freeIconPattern = Nothing + , usedIconPattern = Nothing + } + options = + [ Option "" ["free-icon-pattern"] (ReqArg (\x o -> + o { freeIconPattern = Just $ parseIconPattern x}) "") "" + , Option "" ["used-icon-pattern"] (ReqArg (\x o -> + o { usedIconPattern = Just $ parseIconPattern x}) "") "" + ] diskUConfig :: IO MConfig diskUConfig = mkMConfig "" - ["size", "free", "used", "freep", "usedp", "freebar", "usedbar"] + [ "size", "free", "used", "freep", "usedp" + , "freebar", "freevbar", "freeipat" + , "usedbar", "usedvbar", "usedipat" + ] type DevName = String type Path = String @@ -40,11 +94,15 @@ type DevDataRef = IORef [(DevName, [Float])] mountedDevices :: [String] -> IO [(DevName, Path)] mountedDevices req = do s <- B.readFile "/etc/mtab" - parse `fmap` mapM canon (devs s) + parse `fmap` mapM mbcanon (devs s) where + mbcanon (d, p) = doesFileExist d >>= \e -> + if e + then Just `fmap` canon (d,p) + else return Nothing canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} devs = filter isDev . map (firstTwo . B.words) . B.lines - parse = map undev . filter isReq + parse = map undev . filter isReq . catMaybes firstTwo (a:b:_) = (B.unpack a, B.unpack b) firstTwo _ = ("", "") isDev (d, _) = "/dev/" `isPrefixOf` d @@ -56,10 +114,10 @@ diskDevices req = do s <- B.readFile "/proc/diskstats" parse `fmap` mapM canon (devs s) where - canon (d, p) = do {d' <- canonicalizePath (d); return (d', p)} + canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} devs = map (third . B.words) . B.lines parse = map undev . filter isReq - third (_:_:c:_) = ("/dev/" ++ (B.unpack c), B.unpack c) + third (_:_:c:_) = ("/dev/" ++ B.unpack c, B.unpack c) third _ = ("", "") isReq (d, p) = p `elem` req || drop 5 d `elem` req undev (d, f) = (drop 5 d, f) @@ -120,18 +178,22 @@ devTemplates disks mounted dat = Nothing -> [0, 0, 0] Just (_, xs) -> xs -runDiskIO' :: (String, [Float]) -> Monitor String -runDiskIO' (tmp, xs) = do +runDiskIO' :: DiskIOOpts -> (String, [Float]) -> Monitor String +runDiskIO' opts (tmp, xs) = do s <- mapM (showWithColors speedToStr) xs b <- mapM (showLogBar 0.8) xs + vb <- mapM (showLogVBar 0.8) xs + ipat <- mapM (\(f,v) -> showLogIconPattern (f opts) 0.8 v) + $ zip [totalIconPattern, readIconPattern, writeIconPattern] xs setConfigValue tmp template - parseTemplate $ s ++ b + parseTemplate $ s ++ b ++ vb ++ ipat runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String -runDiskIO dref disks _ = do +runDiskIO dref disks argv = do + opts <- io $ parseDiskIOOpts argv dev <- io $ mountedOrDiskDevices (map fst disks) dat <- io $ mountedData dref (map fst dev) - strs <- mapM runDiskIO' $ devTemplates disks dev dat + strs <- mapM (runDiskIO' opts) $ devTemplates disks dev dat return $ unwords strs startDiskIO :: [(String, String)] -> @@ -152,23 +214,28 @@ fsStats path = do used = fsStatBytesUsed f in return [tot, free, used] -runDiskU' :: String -> String -> Monitor String -runDiskU' tmp path = do +runDiskU' :: DiskUOpts -> String -> String -> Monitor String +runDiskU' opts tmp path = do setConfigValue tmp template [total, free, diff] <- io (handle ign $ fsStats path) - let strs = map sizeToStr [total, free, diff] + let strs = map sizeToStr [free, diff] freep = if total > 0 then free * 100 `div` total else 0 fr = fromIntegral freep / 100 - s <- zipWithM showWithColors' strs [100, freep, 100 - freep] + s <- zipWithM showWithColors' strs [freep, 100 - freep] sp <- showPercentsWithColors [fr, 1 - fr] fb <- showPercentBar (fromIntegral freep) fr + fvb <- showVerticalBar (fromIntegral freep) fr + fipat <- showIconPattern (freeIconPattern opts) fr ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr) - parseTemplate $ s ++ sp ++ [fb, ub] + uvb <- showVerticalBar (fromIntegral $ 100 - freep) (1 - fr) + uipat <- showIconPattern (usedIconPattern opts) (1 - fr) + parseTemplate $ [sizeToStr total] ++ s ++ sp ++ [fb,fvb,fipat,ub,uvb,uipat] where ign = const (return [0, 0, 0]) :: SomeException -> IO [Integer] runDiskU :: [(String, String)] -> [String] -> Monitor String -runDiskU disks _ = do +runDiskU disks argv = do devs <- io $ mountedDevices (map fst disks) - strs <- mapM (\(d, p) -> runDiskU' (findTempl d p disks) p) devs + opts <- io $ parseDiskUOpts argv + strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs return $ unwords strs diff --git a/src/Plugins/Monitors/MPD.hs b/src/Plugins/Monitors/MPD.hs index 96a8f1d..b54962e 100644 --- a/src/Plugins/Monitors/MPD.hs +++ b/src/Plugins/Monitors/MPD.hs @@ -12,17 +12,19 @@ -- ----------------------------------------------------------------------------- -module Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait ) where +module Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait, mpdReady ) where import Data.List +import Data.Maybe (fromMaybe) import Plugins.Monitors.Common import System.Console.GetOpt import qualified Network.MPD as M +import Control.Concurrent (threadDelay) mpdConfig :: IO MConfig mpdConfig = mkMConfig "MPD: <state>" - [ "bar", "state", "statei", "volume", "length" - , "lapsed", "remaining", "plength", "ppos", "file" + [ "bar", "vbar", "ipat", "state", "statei", "volume", "length" + , "lapsed", "remaining", "plength", "ppos", "flags", "file" , "name", "artist", "composer", "performer" , "album", "title", "track", "genre" ] @@ -31,6 +33,7 @@ data MOpts = MOpts { mPlaying :: String , mStopped :: String , mPaused :: String + , mLapsedIconPattern :: Maybe IconPattern } defaultOpts :: MOpts @@ -38,6 +41,7 @@ defaultOpts = MOpts { mPlaying = ">>" , mStopped = "><" , mPaused = "||" + , mLapsedIconPattern = Nothing } options :: [OptDescr (MOpts -> MOpts)] @@ -45,20 +49,35 @@ options = [ Option "P" ["playing"] (ReqArg (\x o -> o { mPlaying = x }) "") "" , Option "S" ["stopped"] (ReqArg (\x o -> o { mStopped = x }) "") "" , Option "Z" ["paused"] (ReqArg (\x o -> o { mPaused = x }) "") "" + , Option "" ["lapsed-icon-pattern"] (ReqArg (\x o -> + o { mLapsedIconPattern = Just $ parseIconPattern x }) "") "" ] runMPD :: [String] -> Monitor String runMPD args = do opts <- io $ mopts args - let mpd = M.withMPD - status <- io $ mpd M.status - song <- io $ mpd M.currentSong + status <- io $ M.withMPD M.status + song <- io $ M.withMPD M.currentSong s <- parseMPD status song opts parseTemplate s mpdWait :: IO () -mpdWait = M.withMPD idle >> return () - where idle = M.idle [M.PlayerS, M.MixerS] +mpdWait = do + status <- M.withMPD $ M.idle [M.PlayerS, M.MixerS] + case status of + Left _ -> threadDelay 10000000 + _ -> return () + +mpdReady :: [String] -> Monitor Bool +mpdReady _ = do + response <- io $ M.withMPD M.ping + case response of + Right _ -> return True + -- Only cases where MPD isn't responding is an issue; bogus information at + -- least won't hold xmobar up. + Left M.NoMPD -> return False + Left (M.ConnectionError _) -> return False + Left _ -> return True mopts :: [String] -> IO MOpts mopts argv = @@ -68,20 +87,23 @@ mopts argv = parseMPD :: M.Response M.Status -> M.Response (Maybe M.Song) -> MOpts -> Monitor [String] -parseMPD (Left e) _ _ = return $ show e:repeat "" +parseMPD (Left e) _ _ = return $ show e:replicate 19 "" parseMPD (Right st) song opts = do songData <- parseSong song bar <- showPercentBar (100 * b) b - return $ [bar, ss, si, vol, len, lap, remain, plen, ppos] ++ songData + vbar <- showVerticalBar (100 * b) b + ipat <- showIconPattern (mLapsedIconPattern opts) b + return $ [bar, vbar, ipat, ss, si, vol, len, lap, remain, plen, ppos, flags] ++ songData where s = M.stState st ss = show s si = stateGlyph s opts - vol = int2str $ M.stVolume st - (p, t) = M.stTime st + vol = int2str $ fromMaybe 0 (M.stVolume st) + (p, t) = fromMaybe (0, 0) (M.stTime st) [lap, len, remain] = map showTime [floor p, t, max 0 (t - floor p)] b = if t > 0 then realToFrac $ p / fromIntegral t else 0 plen = int2str $ M.stPlaylistLength st ppos = maybe "" (int2str . (+1)) $ M.stSongPos st + flags = playbackMode st stateGlyph :: M.State -> MOpts -> String stateGlyph s o = @@ -90,6 +112,14 @@ stateGlyph s o = M.Paused -> mPaused o M.Stopped -> mStopped o +playbackMode :: M.Status -> String +playbackMode s = + concat [if p s then f else "-" | + (p,f) <- [(M.stRepeat,"r"), + (M.stRandom,"z"), + (M.stSingle,"s"), + (M.stConsume,"c")]] + parseSong :: M.Response (Maybe M.Song) -> Monitor [String] parseSong (Left _) = return $ repeat "" parseSong (Right Nothing) = return $ repeat "" diff --git a/src/Plugins/Monitors/Mem.hs b/src/Plugins/Monitors/Mem.hs index 3cf46c7..403fa43 100644 --- a/src/Plugins/Monitors/Mem.hs +++ b/src/Plugins/Monitors/Mem.hs @@ -15,12 +15,45 @@ module Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where import Plugins.Monitors.Common +import qualified Data.Map as M +import System.Console.GetOpt + +data MemOpts = MemOpts + { usedIconPattern :: Maybe IconPattern + , freeIconPattern :: Maybe IconPattern + , availableIconPattern :: Maybe IconPattern + } + +defaultOpts :: MemOpts +defaultOpts = MemOpts + { usedIconPattern = Nothing + , freeIconPattern = Nothing + , availableIconPattern = Nothing + } + +options :: [OptDescr (MemOpts -> MemOpts)] +options = + [ Option "" ["used-icon-pattern"] (ReqArg (\x o -> + o { usedIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["free-icon-pattern"] (ReqArg (\x o -> + o { freeIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["available-icon-pattern"] (ReqArg (\x o -> + o { availableIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO MemOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs memConfig :: IO MConfig memConfig = mkMConfig "Mem: <usedratio>% (<cache>M)" -- template - ["usedbar", "freebar", "usedratio", "freeratio", "total", - "free", "buffer", "cache", "rest", "used"] -- available replacements + ["usedbar", "usedvbar", "usedipat", "freebar", "freevbar", "freeipat", + "availablebar", "availablevbar", "availableipat", + "usedratio", "freeratio", "availableratio", + "total", "free", "buffer", "cache", "available", "used"] -- available replacements fileMEM :: IO String fileMEM = readFile "/proc/meminfo" @@ -28,13 +61,15 @@ fileMEM = readFile "/proc/meminfo" parseMEM :: IO [Float] parseMEM = do file <- fileMEM - let content = map words $ take 4 $ lines file - [total, free, buffer, cache] = map (\line -> (read $ line !! 1 :: Float) / 1024) content - rest = free + buffer + cache - used = total - rest + let content = map words $ take 8 $ lines file + info = M.fromList $ map (\line -> (head line, (read $ line !! 1 :: Float) / 1024)) content + [total, free, buffer, cache] = map (info M.!) ["MemTotal:", "MemFree:", "Buffers:", "Cached:"] + available = M.findWithDefault (free + buffer + cache) "MemAvailable:" info + used = total - available usedratio = used / total freeratio = free / total - return [usedratio, freeratio, total, free, buffer, cache, rest, used, freeratio] + availableratio = available / total + return [usedratio, freeratio, availableratio, total, free, buffer, cache, available, used] totalMem :: IO Float totalMem = fmap ((*1024) . (!!1)) parseMEM @@ -42,20 +77,20 @@ totalMem = fmap ((*1024) . (!!1)) parseMEM usedMem :: IO Float usedMem = fmap ((*1024) . (!!6)) parseMEM -formatMem :: [Float] -> Monitor [String] -formatMem (r:fr:xs) = +formatMem :: MemOpts -> [Float] -> Monitor [String] +formatMem opts (r:fr:ar:xs) = do let f = showDigits 0 - rr = 100 * r - ub <- showPercentBar rr r - fb <- showPercentBar (100 - rr) (1 - r) - rs <- showPercentWithColors r - fs <- showPercentWithColors fr - s <- mapM (showWithColors f) xs - return (ub:fb:rs:fs:s) -formatMem _ = return $ replicate 10 "N/A" + mon i x = [showPercentBar (100 * x) x, showVerticalBar (100 * x) x, showIconPattern i x] + sequence $ mon (usedIconPattern opts) r + ++ mon (freeIconPattern opts) fr + ++ mon (availableIconPattern opts) ar + ++ map showPercentWithColors [r, fr, ar] + ++ map (showWithColors f) xs +formatMem _ _ = replicate 10 `fmap` getConfigValue naString runMem :: [String] -> Monitor String -runMem _ = +runMem argv = do m <- io parseMEM - l <- formatMem m + opts <- io $ parseOpts argv + l <- formatMem opts m parseTemplate l diff --git a/src/Plugins/Monitors/Mpris.hs b/src/Plugins/Monitors/Mpris.hs index 98b4c0f..245c0df 100644 --- a/src/Plugins/Monitors/Mpris.hs +++ b/src/Plugins/Monitors/Mpris.hs @@ -25,6 +25,7 @@ import Text.Printf (printf) import DBus import qualified DBus.Client as DC +import Control.Arrow ((***)) import Data.Maybe ( fromJust ) import Data.Int ( Int32, Int64 ) import System.IO.Unsafe (unsafePerformIO) @@ -43,10 +44,10 @@ instance MprisVersion MprisVersion1 where { methodCallDestination = Just busName } where - busName = busName_ $ "org.mpris." ++ p - objectPath = objectPath_ $ "/Player" - interfaceName = interfaceName_ $ "org.freedesktop.MediaPlayer" - memberName = memberName_ $ "GetMetadata" + busName = busName_ $ "org.mpris." ++ p + objectPath = objectPath_ "/Player" + interfaceName = interfaceName_ "org.freedesktop.MediaPlayer" + memberName = memberName_ "GetMetadata" fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title" , "tracknumber" ] @@ -58,10 +59,10 @@ instance MprisVersion MprisVersion2 where , methodCallBody = arguments } where - busName = busName_ $ "org.mpris.MediaPlayer2." ++ p - objectPath = objectPath_ $ "/org/mpris/MediaPlayer2" - interfaceName = interfaceName_ $ "org.freedesktop.DBus.Properties" - memberName = memberName_ $ "Get" + busName = busName_ $ "org.mpris.MediaPlayer2." ++ p + objectPath = objectPath_ "/org/mpris/MediaPlayer2" + interfaceName = interfaceName_ "org.freedesktop.DBus.Properties" + memberName = memberName_ "Get" arguments = map (toVariant::String -> Variant) ["org.mpris.MediaPlayer2.Player", "Metadata"] @@ -98,7 +99,7 @@ fromVar = fromJust . fromVariant unpackMetadata :: [Variant] -> [(String, Variant)] unpackMetadata [] = [] -unpackMetadata xs = ((map (\(k, v) -> (fromVar k, fromVar v))) . unpack . head) xs where +unpackMetadata xs = (map (fromVar *** fromVar) . unpack . head) xs where unpack v = case variantType v of TypeDictionary _ _ -> dictionaryItems $ fromVar v TypeVariant -> unpack $ fromVar v diff --git a/src/Plugins/Monitors/MultiCpu.hs b/src/Plugins/Monitors/MultiCpu.hs index a1bb082..eab21da 100644 --- a/src/Plugins/Monitors/MultiCpu.hs +++ b/src/Plugins/Monitors/MultiCpu.hs @@ -15,17 +15,48 @@ module Plugins.Monitors.MultiCpu (startMultiCpu) where import Plugins.Monitors.Common +import Control.Applicative ((<$>)) import qualified Data.ByteString.Lazy.Char8 as B import Data.List (isPrefixOf, transpose, unfoldr) import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.Console.GetOpt + +data MultiCpuOpts = MultiCpuOpts + { loadIconPatterns :: [IconPattern] + , loadIconPattern :: Maybe IconPattern + } + +defaultOpts :: MultiCpuOpts +defaultOpts = MultiCpuOpts + { loadIconPatterns = [] + , loadIconPattern = Nothing + } + +options :: [OptDescr (MultiCpuOpts -> MultiCpuOpts)] +options = + [ Option "" ["load-icon-pattern"] (ReqArg (\x o -> + o { loadIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["load-icon-patterns"] (ReqArg (\x o -> + o { loadIconPatterns = parseIconPattern x : loadIconPatterns o }) "") "" + ] + +parseOpts :: [String] -> IO MultiCpuOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +variables :: [String] +variables = ["bar", "vbar","ipat","total","user","nice","system","idle"] +vNum :: Int +vNum = length variables multiCpuConfig :: IO MConfig multiCpuConfig = mkMConfig "Cpu: <total>%" $ - ["auto" ++ k | k <- monitors] ++ + ["auto" ++ k | k <- variables] ++ [ k ++ n | n <- "" : map show [0 :: Int ..] - , k <- monitors] - where monitors = ["bar","total","user","nice","system","idle"] + , k <- variables] type CpuDataRef = IORef [[Float]] @@ -48,34 +79,41 @@ parseCpuData cref = percent :: [Float] -> [Float] -> [Float] percent b a = if tot > 0 then map (/ tot) $ take 4 dif else [0, 0, 0, 0] where dif = zipWith (-) b a - tot = foldr (+) 0 dif + tot = sum dif -formatMultiCpus :: [[Float]] -> Monitor [String] -formatMultiCpus [] = return [] -formatMultiCpus xs = fmap concat $ mapM formatCpu xs +formatMultiCpus :: MultiCpuOpts -> [[Float]] -> Monitor [String] +formatMultiCpus _ [] = return [] +formatMultiCpus opts xs = concat <$> mapM (\(i, x) -> formatCpu opts i x) (zip [0..] xs) -formatCpu :: [Float] -> Monitor [String] -formatCpu xs - | length xs < 4 = showPercentsWithColors $ replicate 6 0.0 - | otherwise = let t = foldr (+) 0 $ take 3 xs +formatCpu :: MultiCpuOpts -> Int -> [Float] -> Monitor [String] +formatCpu opts i xs + | length xs < 4 = showPercentsWithColors $ replicate vNum 0.0 + | otherwise = let t = sum $ take 3 xs in do b <- showPercentBar (100 * t) t + h <- showVerticalBar (100 * t) t + d <- showIconPattern tryString t ps <- showPercentsWithColors (t:xs) - return (b:ps) + return (b:h:d:ps) + where tryString + | i == 0 = loadIconPattern opts + | i <= length (loadIconPatterns opts) = Just $ (loadIconPatterns opts) !! (i - 1) + | otherwise = Nothing splitEvery :: (Eq a) => Int -> [a] -> [[a]] splitEvery n = unfoldr (\x -> if null x then Nothing else Just $ splitAt n x) groupData :: [String] -> [[String]] -groupData = transpose . tail . splitEvery 6 +groupData = transpose . tail . splitEvery vNum formatAutoCpus :: [String] -> Monitor [String] -formatAutoCpus [] = return $ replicate 6 "" +formatAutoCpus [] = return $ replicate vNum "" formatAutoCpus xs = return $ map unwords (groupData xs) runMultiCpu :: CpuDataRef -> [String] -> Monitor String -runMultiCpu cref _ = +runMultiCpu cref argv = do c <- io $ parseCpuData cref - l <- formatMultiCpus c + opts <- io $ parseOpts argv + l <- formatMultiCpus opts c a <- formatAutoCpus l parseTemplate $ a ++ l diff --git a/src/Plugins/Monitors/Net.hs b/src/Plugins/Monitors/Net.hs index b8adc74..5954a77 100644 --- a/src/Plugins/Monitors/Net.hs +++ b/src/Plugins/Monitors/Net.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Net --- Copyright : (c) 2011, 2012 Jose Antonio Ortega Ruiz +-- Copyright : (c) 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz -- (c) 2007-2010 Andrea Rossato -- License : BSD-style (see LICENSE) -- @@ -22,12 +22,47 @@ import Plugins.Monitors.Common import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) -import Control.Monad (forM, filterM) +import Control.Monad (forM, filterM, liftM) import System.Directory (getDirectoryContents, doesFileExist) import System.FilePath ((</>)) +import System.Console.GetOpt import qualified Data.ByteString.Lazy.Char8 as B +data NetOpts = NetOpts + { rxIconPattern :: Maybe IconPattern + , txIconPattern :: Maybe IconPattern + } + +defaultOpts :: NetOpts +defaultOpts = NetOpts + { rxIconPattern = Nothing + , txIconPattern = Nothing + } + +options :: [OptDescr (NetOpts -> NetOpts)] +options = + [ Option "" ["rx-icon-pattern"] (ReqArg (\x o -> + o { rxIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["tx-icon-pattern"] (ReqArg (\x o -> + o { txIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO NetOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +data UnitPerSec = Bs | KBs | MBs | GBs deriving (Eq,Enum,Ord) +data NetValue = NetValue Float UnitPerSec deriving (Eq,Show) + +instance Show UnitPerSec where + show Bs = "B/s" + show KBs = "KB/s" + show MBs = "MB/s" + show GBs = "GB/s" + data NetDev = NA | NI String | ND String Float Float deriving (Eq,Show,Read) @@ -42,8 +77,8 @@ instance Ord NetDev where compare NA _ = LT compare _ NA = GT compare (NI _) (NI _) = EQ - compare (NI _) (ND _ _ _) = LT - compare (ND _ _ _) (NI _) = GT + compare (NI _) (ND {}) = LT + compare (ND {}) (NI _) = GT compare (ND _ x1 y1) (ND _ x2 y2) = if downcmp /= EQ then downcmp @@ -53,7 +88,7 @@ instance Ord NetDev where netConfig :: IO MConfig netConfig = mkMConfig "<dev>: <rx>KB|<tx>KB" -- template - ["dev", "rx", "tx", "rxbar", "txbar"] -- available replacements + ["dev", "rx", "tx", "rxbar", "rxvbar", "rxipat", "txbar", "txvbar", "txipat"] -- available replacements operstateDir :: String -> FilePath operstateDir d = "/sys/class/net" </> d </> "operstate" @@ -67,14 +102,14 @@ existingDevs = getDirectoryContents "/sys/class/net" >>= filterM isDev isUp :: String -> IO Bool isUp d = do operstate <- B.readFile (operstateDir d) - return $ "up" == (B.unpack . head . B.lines) operstate + return $ (B.unpack . head . B.lines) operstate `elem` ["up", "unknown"] readNetDev :: [String] -> IO NetDev readNetDev (d:x:y:_) = do up <- isUp d return (if up then ND d (r x) (r y) else NI d) where r s | s == "" = 0 - | otherwise = read s / 1024 + | otherwise = read s readNetDev _ = return NA @@ -97,24 +132,28 @@ findNetDev dev = do isDev (NI d) = d == dev isDev NA = False -formatNet :: Float -> Monitor (String, String) -formatNet d = do +formatNet :: Maybe IconPattern -> Float -> Monitor (String, String, String, String) +formatNet mipat d = do s <- getConfigValue useSuffix dd <- getConfigValue decDigits - let str = if s then (++"Kb/s") . showDigits dd else showDigits dd + let str True v = showDigits dd d' ++ show u + where (NetValue d' u) = byteNetVal v + str False v = showDigits dd $ v / 1024 b <- showLogBar 0.9 d - x <- showWithColors str d - return (x, b) + vb <- showLogVBar 0.9 d + ipat <- showLogIconPattern mipat 0.9 d + x <- showWithColors (str s) d + return (x, b, vb, ipat) -printNet :: NetDev -> Monitor String -printNet nd = +printNet :: NetOpts -> NetDev -> Monitor String +printNet opts nd = case nd of ND d r t -> do - (rx, rb) <- formatNet r - (tx, tb) <- formatNet t - parseTemplate [d,rx,tx,rb,tb] + (rx, rb, rvb, ripat) <- formatNet (rxIconPattern opts) r + (tx, tb, tvb, tipat) <- formatNet (txIconPattern opts) t + parseTemplate [d,rx,tx,rb,rvb,ripat,tb,tvb,tipat] NI _ -> return "" - NA -> return "N/A" + NA -> getConfigValue naString parseNet :: NetDevRef -> String -> IO NetDev parseNet nref nd = do @@ -132,14 +171,20 @@ parseNet nref nd = do return $ diffRate n0 n1 runNet :: NetDevRef -> String -> [String] -> Monitor String -runNet nref i _ = io (parseNet nref i) >>= printNet +runNet nref i argv = do + dev <- io $ parseNet nref i + opts <- io $ parseOpts argv + printNet opts dev parseNets :: [(NetDevRef, String)] -> IO [NetDev] -parseNets = mapM $ \(ref, i) -> parseNet ref i +parseNets = mapM $ uncurry parseNet runNets :: [(NetDevRef, String)] -> [String] -> Monitor String -runNets refs _ = io (parseActive refs) >>= printNet - where parseActive refs' = parseNets refs' >>= return . selectActive +runNets refs argv = do + dev <- io $ parseActive refs + opts <- io $ parseOpts argv + printNet opts dev + where parseActive refs' = liftM selectActive (parseNets refs') selectActive = maximum startNet :: String -> [String] -> Int -> (String -> IO ()) -> IO () @@ -158,3 +203,10 @@ startDynNet a r cb = do _ <- parseNet nref d return (nref, d) runM a netConfig (runNets refs) r cb + +byteNetVal :: Float -> NetValue +byteNetVal v + | v < 1024**1 = NetValue v Bs + | v < 1024**2 = NetValue (v/1024**1) KBs + | v < 1024**3 = NetValue (v/1024**2) MBs + | otherwise = NetValue (v/1024**3) GBs diff --git a/src/Plugins/Monitors/Swap.hs b/src/Plugins/Monitors/Swap.hs index 107eb1e..b6c5019 100644 --- a/src/Plugins/Monitors/Swap.hs +++ b/src/Plugins/Monitors/Swap.hs @@ -33,8 +33,8 @@ parseMEM = | l /= [] = head l !! i | otherwise = B.empty fs s l - | l == [] = False - | otherwise = head l == B.pack s + | null l = False + | otherwise = head l == B.pack s get_data s = flip (/) 1024 . read . B.unpack . li 1 . filter (fs s) st = map B.words . B.lines $ file tot = get_data "SwapTotal:" st diff --git a/src/Plugins/Monitors/Thermal.hs b/src/Plugins/Monitors/Thermal.hs index a3ffe6d..6013511 100644 --- a/src/Plugins/Monitors/Thermal.hs +++ b/src/Plugins/Monitors/Thermal.hs @@ -14,6 +14,7 @@ module Plugins.Monitors.Thermal where +import Control.Monad (liftM) import qualified Data.ByteString.Lazy.Char8 as B import Plugins.Monitors.Common import System.Posix.Files (fileExist) @@ -32,11 +33,9 @@ runThermal args = do let zone = head args file = "/proc/acpi/thermal_zone/" ++ zone ++ "/temperature" exists <- io $ fileExist file - case exists of - False -> return $ "Thermal (" ++ zone ++ "): N/A" - True -> do number <- io $ B.readFile file - >>= return . (read :: String -> Int) - . stringParser (1, 0) - thermal <- showWithColors show number - parseTemplate [ thermal ] + if exists + then do number <- io $ liftM ((read :: String -> Int) . stringParser (1, 0)) (B.readFile file) + thermal <- showWithColors show number + parseTemplate [ thermal ] + else return $ "Thermal (" ++ zone ++ "): N/A" diff --git a/src/Plugins/Monitors/ThermalZone.hs b/src/Plugins/Monitors/ThermalZone.hs index 55fb2ca..d692191 100644 --- a/src/Plugins/Monitors/ThermalZone.hs +++ b/src/Plugins/Monitors/ThermalZone.hs @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- | -- Module : Plugins.Monitors.ThermalZone --- Copyright : (c) 2011 Jose Antonio Ortega Ruiz +-- Copyright : (c) 2011, 2013 Jose Antonio Ortega Ruiz -- License : BSD3-style (see LICENSE) -- -- Maintainer : jao@gnu.org @@ -39,5 +39,4 @@ runThermalZone args = do then do mdegrees <- io $ B.readFile file >>= parse temp <- showWithColors show (mdegrees `quot` 1000) parseTemplate [ temp ] - else return "N/A" - + else getConfigValue naString diff --git a/src/Plugins/Monitors/Top.hs b/src/Plugins/Monitors/Top.hs index 6f16bdb..3d246ff 100644 --- a/src/Plugins/Monitors/Top.hs +++ b/src/Plugins/Monitors/Top.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Top --- Copyright : (c) Jose A Ortega Ruiz +-- Copyright : (c) 2010, 2011, 2012, 2013, 2014 Jose A Ortega Ruiz -- License : BSD-style (see LICENSE) -- -- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> @@ -57,10 +57,15 @@ processes :: IO [FilePath] processes = fmap (filter isPid) (getDirectoryContents "/proc") where isPid = (`elem` ['0'..'9']) . head +statWords :: [String] -> [String] +statWords line@(x:pn:ppn:xs) = + if last pn == ')' then line else statWords (x:(pn ++ " " ++ ppn):xs) +statWords _ = replicate 52 "0" + getProcessData :: FilePath -> IO [String] getProcessData pidf = handle ign $ withFile ("/proc" </> pidf </> "stat") ReadMode readWords - where readWords = fmap words . hGetLine + where readWords = fmap (statWords . words) . hGetLine ign = const (return []) :: SomeException -> IO [String] handleProcesses :: ([String] -> a) -> IO [a] @@ -96,7 +101,7 @@ meminfos = handleProcesses meminfo showMemInfo :: Float -> MemInfo -> Monitor [String] showMemInfo scale (nm, rss) = - showInfo nm (showWithUnits 2 1 rss) (100 * rss / sc) + showInfo nm (showWithUnits 3 1 rss) (100 * rss / sc) where sc = if scale > 0 then scale else 100 showMemInfos :: [MemInfo] -> Monitor [[String]] diff --git a/src/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs index f3d0f4c..8c39b9f 100644 --- a/src/Plugins/Monitors/Volume.hs +++ b/src/Plugins/Monitors/Volume.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Volume --- Copyright : (c) 2011 Thomas Tuegel +-- Copyright : (c) 2011, 2013 Thomas Tuegel -- License : BSD-style (see LICENSE) -- -- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> @@ -24,7 +24,7 @@ import System.Console.GetOpt volumeConfig :: IO MConfig volumeConfig = mkMConfig "Vol: <volume>% <status>" - ["volume", "volumebar", "dB","status"] + ["volume", "volumebar", "volumevbar", "dB","status", "volumeipat"] data VolumeOpts = VolumeOpts @@ -34,6 +34,7 @@ data VolumeOpts = VolumeOpts , offColor :: Maybe String , highDbThresh :: Float , lowDbThresh :: Float + , volumeIconPattern :: Maybe IconPattern } defaultOpts :: VolumeOpts @@ -44,6 +45,7 @@ defaultOpts = VolumeOpts , offColor = Just "red" , highDbThresh = -5.0 , lowDbThresh = -30.0 + , volumeIconPattern = Nothing } options :: [OptDescr (VolumeOpts -> VolumeOpts)] @@ -54,6 +56,8 @@ options = , Option "" ["highd"] (ReqArg (\x o -> o { highDbThresh = read x }) "") "" , Option "C" ["onc"] (ReqArg (\x o -> o { onColor = Just x }) "") "" , Option "c" ["offc"] (ReqArg (\x o -> o { offColor = Just x }) "") "" + , Option "" ["volume-icon-pattern"] (ReqArg (\x o -> + o { volumeIconPattern = Just $ parseIconPattern x }) "") "" ] parseOpts :: [String] -> IO VolumeOpts @@ -76,6 +80,14 @@ formatVolBar :: Integer -> Integer -> Integer -> Monitor String formatVolBar lo hi v = showPercentBar (100 * x) x where x = percent v lo hi +formatVolVBar :: Integer -> Integer -> Integer -> Monitor String +formatVolVBar lo hi v = + showVerticalBar (100 * x) x where x = percent v lo hi + +formatVolDStr :: Maybe IconPattern -> Integer -> Integer -> Integer -> Monitor String +formatVolDStr ipat lo hi v = + showIconPattern ipat $ percent v lo hi + switchHelper :: VolumeOpts -> (VolumeOpts -> Maybe String) -> (VolumeOpts -> String) @@ -110,16 +122,20 @@ formatDb opts dbi = do runVolume :: String -> String -> [String] -> Monitor String runVolume mixerName controlName argv = do opts <- io $ parseOpts argv - control <- io $ getControlByName mixerName controlName - (lo, hi) <- io . liftMaybe $ getRange <$> volumeControl control - val <- getVal $ volumeControl control - db <- getDB $ volumeControl control - sw <- getSw $ switchControl control + (lo, hi, val, db, sw) <- io $ withMixer mixerName $ \mixer -> do + control <- getControlByName mixer controlName + (lo, hi) <- liftMaybe $ getRange <$> volumeControl control + val <- getVal $ volumeControl control + db <- getDB $ volumeControl control + sw <- getSw $ switchControl control + return (lo, hi, val, db, sw) p <- liftMonitor $ liftM3 formatVol lo hi val b <- liftMonitor $ liftM3 formatVolBar lo hi val + v <- liftMonitor $ liftM3 formatVolVBar lo hi val d <- getFormatDB opts db s <- getFormatSwitch opts sw - parseTemplate [p, b, d, s] + ipat <- liftMonitor $ liftM3 (formatVolDStr $ volumeIconPattern opts) lo hi val + parseTemplate [p, b, v, d, s, ipat] where @@ -135,28 +151,28 @@ runVolume mixerName controlName argv = do liftMaybe = fmap (liftM2 (,) (fmap fst) (fmap snd)) . sequenceA liftMonitor :: Maybe (Monitor String) -> Monitor String - liftMonitor Nothing = return unavailable + liftMonitor Nothing = unavailable liftMonitor (Just m) = m - getDB :: Maybe Volume -> Monitor (Maybe Integer) + getDB :: Maybe Volume -> IO (Maybe Integer) getDB Nothing = return Nothing - getDB (Just v) = io $ AE.catch (getChannel FrontLeft $ dB v) - (const $ return $ Just 0) + getDB (Just v) = AE.catch (getChannel FrontLeft $ dB v) + (const $ return $ Just 0) - getVal :: Maybe Volume -> Monitor (Maybe Integer) + getVal :: Maybe Volume -> IO (Maybe Integer) getVal Nothing = return Nothing - getVal (Just v) = io $ getChannel FrontLeft $ value v + getVal (Just v) = getChannel FrontLeft $ value v - getSw :: Maybe Switch -> Monitor (Maybe Bool) + getSw :: Maybe Switch -> IO (Maybe Bool) getSw Nothing = return Nothing - getSw (Just s) = io $ getChannel FrontLeft s + getSw (Just s) = getChannel FrontLeft s getFormatDB :: VolumeOpts -> Maybe Integer -> Monitor String - getFormatDB _ Nothing = return unavailable + getFormatDB _ Nothing = unavailable getFormatDB opts (Just d) = formatDb opts d getFormatSwitch :: VolumeOpts -> Maybe Bool -> Monitor String - getFormatSwitch _ Nothing = return unavailable + getFormatSwitch _ Nothing = unavailable getFormatSwitch opts (Just sw) = formatSwitch opts sw - unavailable = "N/A" + unavailable = getConfigValue naString diff --git a/src/Plugins/Monitors/Weather.hs b/src/Plugins/Monitors/Weather.hs index 1277438..3cfbc74 100644 --- a/src/Plugins/Monitors/Weather.hs +++ b/src/Plugins/Monitors/Weather.hs @@ -16,13 +16,11 @@ module Plugins.Monitors.Weather where import Plugins.Monitors.Common -import Control.Monad (when) -import System.Process -import System.Exit -import System.IO +import qualified Control.Exception as CE -import Text.ParserCombinators.Parsec +import Network.HTTP +import Text.ParserCombinators.Parsec weatherConfig :: IO MConfig weatherConfig = mkMConfig @@ -33,12 +31,16 @@ weatherConfig = mkMConfig , "month" , "day" , "hour" - , "wind" + , "windCardinal" + , "windAzimuth" + , "windMph" + , "windKnots" , "visibility" , "skyCondition" , "tempC" , "tempF" - , "dewPoint" + , "dewPointC" + , "dewPointF" , "rh" , "pressure" ] @@ -50,12 +52,16 @@ data WeatherInfo = , month :: String , day :: String , hour :: String - , wind :: String + , windCardinal :: String + , windAzimuth :: String + , windMph :: String + , windKnots :: String , visibility :: String , skyCondition :: String , tempC :: Int , tempF :: Int - , dewPoint :: String + , dewPointC :: Int + , dewPointF :: Int , humidity :: Int , pressure :: Int } deriving (Show) @@ -69,7 +75,41 @@ pTime = do y <- getNumbersAsString char ' ' (h:hh:mi:mimi) <- getNumbersAsString char ' ' - return (y, m, d ,([h]++[hh]++":"++[mi]++mimi)) + return (y, m, d ,h:hh:":"++mi:mimi) + +-- Occasionally there is no wind and a METAR report gives simply, "Wind: Calm:0" +pWind0 :: + ( + String -- cardinal direction + , String -- azimuth direction + , String -- speed (MPH) + , String -- speed (knot) + ) +pWind0 = + ("μ", "μ", "0", "0") + +pWind :: + Parser ( + String -- cardinal direction + , String -- azimuth direction + , String -- speed (MPH) + , String -- speed (knot) + ) +pWind = + let tospace = manyTill anyChar (char ' ') + wind0 = do manyTill skipRestOfLine (string "Wind: Calm:0") + return pWind0 + wind = do manyTill skipRestOfLine (string "Wind: from the ") + cardinal <- tospace + char '(' + azimuth <- tospace + string "degrees) at " + mph <- tospace + string "MPH (" + knot <- tospace + manyTill anyChar newline + return (cardinal, azimuth, mph, knot) + in try wind0 <|> wind pTemp :: Parser (Int, Int) pTemp = do let num = digit <|> char '-' <|> char '.' @@ -77,10 +117,10 @@ pTemp = do let num = digit <|> char '-' <|> char '.' manyTill anyChar $ char '(' c <- manyTill num $ char ' ' skipRestOfLine - return $ (floor (read c :: Double), floor (read f :: Double)) + return (floor (read c :: Double), floor (read f :: Double)) pRh :: Parser Int -pRh = do s <- manyTill digit $ (char '%' <|> char '.') +pRh = do s <- manyTill digit (char '%' <|> char '.') return $ read s pPressure :: Parser Int @@ -89,53 +129,84 @@ pPressure = do manyTill anyChar $ char '(' skipRestOfLine return $ read s +{- + example of 'http://weather.noaa.gov/pub/data/observations/metar/decoded/VTUD.TXT': + Station name not available + Aug 11, 2013 - 10:00 AM EDT / 2013.08.11 1400 UTC + Wind: from the N (350 degrees) at 1 MPH (1 KT):0 + Visibility: 4 mile(s):0 + Sky conditions: mostly clear + Temperature: 77 F (25 C) + Dew Point: 73 F (23 C) + Relative Humidity: 88% + Pressure (altimeter): 29.77 in. Hg (1008 hPa) + ob: VTUD 111400Z 35001KT 8000 FEW030 25/23 Q1008 A2977 INFO R RWY30 + cycle: 14 +-} parseData :: Parser [WeatherInfo] parseData = - do st <- getAllBut "," - space - ss <- getAllBut "(" + do (st, ss) <- try (string "Station name not available" >> return ("??", "??")) <|> + (do st <- getAllBut "," + space + ss <- getAllBut "(" + return (st, ss) + ) skipRestOfLine >> getAllBut "/" (y,m,d,h) <- pTime - w <- getAfterString "Wind: " + (wc, wa, wm, wk) <- pWind v <- getAfterString "Visibility: " sk <- getAfterString "Sky conditions: " skipTillString "Temperature: " (tC,tF) <- pTemp - dp <- getAfterString "Dew Point: " + skipTillString "Dew Point: " + (dC, dF) <- pTemp skipTillString "Relative Humidity: " rh <- pRh skipTillString "Pressure (altimeter): " p <- pPressure manyTill skipRestOfLine eof - return $ [WI st ss y m d h w v sk tC tF dp rh p] + return [WI st ss y m d h wc wa wm wk v sk tC tF dC dF rh p] defUrl :: String defUrl = "http://weather.noaa.gov/pub/data/observations/metar/decoded/" +stationUrl :: String -> String +stationUrl station = defUrl ++ station ++ ".TXT" + getData :: String -> IO String -getData url= - do (i,o,e,p) <- runInteractiveCommand ("curl " ++ defUrl ++ url ++ ".TXT") - exit <- waitForProcess p - let closeHandles = do hClose o - hClose i - hClose e - case exit of - ExitSuccess -> do str <- hGetContents o - when (str == str) $ return () - closeHandles - return str - _ -> do closeHandles - return "Could not retrieve data" +getData station = do + let request = getRequest (stationUrl station) + CE.catch (simpleHTTP request >>= getResponseBody) errHandler + where errHandler :: CE.IOException -> IO String + errHandler _ = return "<Could not retrieve data>" formatWeather :: [WeatherInfo] -> Monitor String -formatWeather [(WI st ss y m d h w v sk tC tF dp r p)] = +formatWeather [WI st ss y m d h wc wa wm wk v sk tC tF dC dF r p] = do cel <- showWithColors show tC far <- showWithColors show tF - parseTemplate [st, ss, y, m, d, h, w, v, sk, cel, far, dp, show r , show p ] -formatWeather _ = return "N/A" + parseTemplate [st, ss, y, m, d, h, wc, wa, wm, wk, v, sk, cel, far, show dC, show dF, show r , show p ] +formatWeather _ = getConfigValue naString runWeather :: [String] -> Monitor String runWeather str = do d <- io $ getData $ head str i <- io $ runP parseData d formatWeather i + +weatherReady :: [String] -> Monitor Bool +weatherReady str = do + let station = head str + request = headRequest (stationUrl station) + io $ CE.catch (simpleHTTP request >>= checkResult) errHandler + where errHandler :: CE.IOException -> IO Bool + errHandler _ = return False + checkResult result = + case result of + Left _ -> return False + Right response -> + case rspCode response of + -- Permission or network errors are failures; anything + -- else is recoverable. + (4, _, _) -> return False + (5, _, _) -> return False + (_, _, _) -> return True diff --git a/src/Plugins/Monitors/Wireless.hs b/src/Plugins/Monitors/Wireless.hs index 8d32c99..b1e3c7e 100644 --- a/src/Plugins/Monitors/Wireless.hs +++ b/src/Plugins/Monitors/Wireless.hs @@ -14,21 +14,49 @@ module Plugins.Monitors.Wireless (wirelessConfig, runWireless) where +import System.Console.GetOpt + import Plugins.Monitors.Common import IWlib +data WirelessOpts = WirelessOpts + { qualityIconPattern :: Maybe IconPattern + } + +defaultOpts :: WirelessOpts +defaultOpts = WirelessOpts + { qualityIconPattern = Nothing + } + +options :: [OptDescr (WirelessOpts -> WirelessOpts)] +options = + [ Option "" ["quality-icon-pattern"] (ReqArg (\d opts -> + opts { qualityIconPattern = Just $ parseIconPattern d }) "") "" + ] + +parseOpts :: [String] -> IO WirelessOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + wirelessConfig :: IO MConfig wirelessConfig = - mkMConfig "<essid> <quality>" ["essid", "quality", "qualitybar"] + mkMConfig "<essid> <quality>" ["essid", "quality", "qualitybar", "qualityvbar", "qualityipat"] -runWireless :: [String] -> Monitor String -runWireless (iface:_) = do +runWireless :: String -> [String] -> Monitor String +runWireless iface args = do + opts <- io $ parseOpts args wi <- io $ getWirelessInfo iface + na <- getConfigValue naString let essid = wiEssid wi qlty = fromIntegral $ wiQuality wi - e = if essid == "" then "N/A" else essid + e = if essid == "" then na else essid ep <- showWithPadding e - q <- if qlty >= 0 then showPercentWithColors (qlty/100) else showWithPadding "" + q <- if qlty >= 0 + then showPercentWithColors (qlty / 100) + else showWithPadding "" qb <- showPercentBar qlty (qlty / 100) - parseTemplate [ep, q, qb] -runWireless _ = return "" + qvb <- showVerticalBar qlty (qlty / 100) + qipat <- showIconPattern (qualityIconPattern opts) (qlty / 100) + parseTemplate [ep, q, qb, qvb, qipat] diff --git a/src/Plugins/PipeReader.hs b/src/Plugins/PipeReader.hs index 7efea60..058ed46 100644 --- a/src/Plugins/PipeReader.hs +++ b/src/Plugins/PipeReader.hs @@ -19,7 +19,7 @@ import Plugins import System.Posix.Files import Control.Concurrent(threadDelay) import Control.Exception -import Control.Monad(when) +import Control.Monad(forever, unless) data PipeReader = PipeReader String String deriving (Read, Show) @@ -28,21 +28,18 @@ instance Exec PipeReader where alias (PipeReader _ a) = a start (PipeReader p _) cb = do let (def, pipe) = split ':' p - when (not $ null def) (cb def) + unless (null def) (cb def) checkPipe pipe h <- openFile pipe ReadWriteMode forever (hGetLineSafe h >>= cb) where - forever a = a >> forever a - split c xs | c `elem` xs = let (pre, post) = span ((/=) c) xs - in (pre, dropWhile ((==) c) post) + split c xs | c `elem` xs = let (pre, post) = span (c /=) xs + in (pre, dropWhile (c ==) post) | otherwise = ([], xs) checkPipe :: FilePath -> IO () -checkPipe file = do +checkPipe file = handle (\(SomeException _) -> waitForPipe) $ do - status <- getFileStatus file - if isNamedPipe status - then return () - else waitForPipe + status <- getFileStatus file + unless (isNamedPipe status) waitForPipe where waitForPipe = threadDelay 1000 >> checkPipe file diff --git a/src/Plugins/StdinReader.hs b/src/Plugins/StdinReader.hs index f242f93..31d041e 100644 --- a/src/Plugins/StdinReader.hs +++ b/src/Plugins/StdinReader.hs @@ -8,11 +8,15 @@ -- Stability : unstable -- Portability : unportable -- --- A plugin for reading from stdin +-- A plugin for reading from `stdin`. +-- +-- Exports: +-- - `StdinReader` to safely display stdin content (striping actions). +-- - `UnsafeStdinReader` to display stdin content as-is. -- ----------------------------------------------------------------------------- -module Plugins.StdinReader where +module Plugins.StdinReader (StdinReader(..)) where import Prelude import System.Posix.Process @@ -22,14 +26,19 @@ import Control.Exception (SomeException(..), handle) import Plugins import Actions (stripActions) -data StdinReader = StdinReader deriving (Read, Show) +data StdinReader = StdinReader | UnsafeStdinReader + deriving (Read, Show) instance Exec StdinReader where - start StdinReader cb = do + start stdinReader cb = do s <- handle (\(SomeException e) -> do hPrint stderr e; return "") (hGetLineSafe stdin) - cb (stripActions s) - eof <- hIsEOF stdin + cb $ escape stdinReader s + eof <- isEOF if eof then exitImmediately ExitSuccess - else start StdinReader cb + else start stdinReader cb + +escape :: StdinReader -> String -> String +escape StdinReader = stripActions +escape UnsafeStdinReader = id diff --git a/src/Plugins/XMonadLog.hs b/src/Plugins/XMonadLog.hs index 8f63dc9..158b7ef 100644 --- a/src/Plugins/XMonadLog.hs +++ b/src/Plugins/XMonadLog.hs @@ -31,20 +31,35 @@ import XUtil (nextEvent') import Actions (stripActions) data XMonadLog = XMonadLog + | UnsafeXMonadLog | XPropertyLog String + | UnsafeXPropertyLog String | NamedXPropertyLog String String + | UnsafeNamedXPropertyLog String String deriving (Read, Show) instance Exec XMonadLog where alias XMonadLog = "XMonadLog" + alias UnsafeXMonadLog = "UnsafeXMonadLog" alias (XPropertyLog atom) = atom alias (NamedXPropertyLog _ name) = name + alias (UnsafeXPropertyLog atom) = atom + alias (UnsafeNamedXPropertyLog _ name) = name start x cb = do let atom = case x of - XMonadLog -> "_XMONAD_LOG" - XPropertyLog a -> a + XMonadLog -> "_XMONAD_LOG" + UnsafeXMonadLog -> "_XMONAD_LOG" + XPropertyLog a -> a + UnsafeXPropertyLog a -> a NamedXPropertyLog a _ -> a + UnsafeNamedXPropertyLog a _ -> a + sanitize = case x of + UnsafeXMonadLog -> id + UnsafeXPropertyLog _ -> id + UnsafeNamedXPropertyLog _ _ -> id + _ -> stripActions + d <- openDisplay "" xlog <- internAtom d atom False @@ -53,7 +68,7 @@ instance Exec XMonadLog where let update = do mwp <- getWindowProperty8 d xlog root - maybe (return ()) (cb . stripActions. decodeCChar) mwp + maybe (return ()) (cb . sanitize . decodeCChar) mwp update diff --git a/src/Signal.hs b/src/Signal.hs index 34d8cd7..a828db6 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -22,6 +22,7 @@ import Data.Typeable (Typeable) import Control.Concurrent.STM import Control.Exception hiding (handle) import System.Posix.Signals +import Graphics.X11.Types (Button) import Graphics.X11.Xlib.Types (Position) #ifdef DBUS @@ -41,7 +42,7 @@ data SignalType = Wakeup | Reveal Int | Toggle Int | TogglePersistent - | Action Position + | Action Button Position deriving (Read, Show) #ifdef DBUS diff --git a/src/StatFS.hsc b/src/StatFS.hsc index 050c19b..a9046c1 100644 --- a/src/StatFS.hsc +++ b/src/StatFS.hsc @@ -54,7 +54,7 @@ data CStatfs #ifdef IS_BSD_SYSTEM foreign import ccall unsafe "sys/mount.h statfs" #else -foreign import ccall unsafe "sys/statvfs.h statvfs" +foreign import ccall unsafe "sys/vfs.h statvfs" #endif c_statfs :: CString -> Ptr CStatfs -> IO CInt diff --git a/src/Window.hs b/src/Window.hs index 89a4ca9..95ad3a3 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Window --- Copyright : (c) 2011-13 Jose A. Ortega Ruiz +-- Copyright : (c) 2011-14 Jose A. Ortega Ruiz -- : (c) 2012 Jochen Keil -- License : BSD-style (see LICENSE) -- @@ -16,13 +16,16 @@ module Window where import Prelude +import Control.Applicative ((<$>)) import Control.Monad (when, unless) import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama import Foreign.C.Types (CLong) -import Data.Maybe(fromMaybe) +import Data.Function (on) +import Data.List (maximumBy) +import Data.Maybe (fromMaybe) import System.Posix.Process (getProcessID) import Config @@ -38,7 +41,7 @@ createWin d fs c = do rootw <- rootWindow d dflt (as,ds) <- textExtents fs "0" let ht = as + ds + 4 - r = setPosition (position c) srs (fi ht) + r = setPosition c (position c) srs (fi ht) win <- newWindow d (defaultScreenOfDisplay d) rootw r (overrideRedirect c) setProperties c d win setStruts r c d win srs @@ -52,13 +55,13 @@ repositionWin d win fs c = do srs <- getScreenInfo d (as,ds) <- textExtents fs "0" let ht = as + ds + 4 - r = setPosition (position c) srs (fi ht) + r = setPosition c (position c) srs (fi ht) moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) setStruts r c d win srs return r -setPosition :: XPosition -> [Rectangle] -> Dimension -> Rectangle -setPosition p rs ht = +setPosition :: Config -> XPosition -> [Rectangle] -> Dimension -> Rectangle +setPosition c p rs ht = case p' of Top -> Rectangle rx ry rw h TopP l r -> Rectangle (rx + fi l) ry (rw - fi l - fi r) h @@ -69,11 +72,11 @@ setPosition p rs ht = BottomP l r -> Rectangle (rx + fi l) ny (rw - fi l - fi r) h BottomSize a i ch -> Rectangle (ax a i) (ny' ch) (nw i) (mh ch) Static cx cy cw ch -> Rectangle (fi cx) (fi cy) (fi cw) (fi ch) - OnScreen _ p'' -> setPosition p'' [scr] ht + OnScreen _ p'' -> setPosition c p'' [scr] ht where (scr@(Rectangle rx ry rw rh), p') = - case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) - _ -> (head rs, p) + case p of OnScreen i x -> (fromMaybe (picker rs) $ safeIndex i rs, x) + _ -> (picker rs, p) ny = ry + fi (rh - ht) center i = rx + fi (div (remwid i) 2) right i = rx + fi (remwid i) @@ -87,6 +90,9 @@ setPosition p rs ht = mh h' = max (fi h') h ny' h' = ry + fi (rh - mh h') safeIndex i = lookup i . zip [0..] + picker = if pickBroadest c + then maximumBy (compare `on` rect_width) + else head setProperties :: Config -> Display -> Window -> IO () setProperties c d w = do @@ -158,20 +164,22 @@ getStaticStrutValues (Static cx cy cw ch) rwh xe = xs + cw getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] -drawBorder :: Border -> Display -> Drawable -> GC -> Pixel +drawBorder :: Border -> Int -> Display -> Drawable -> GC -> Pixel -> Dimension -> Dimension -> IO () -drawBorder b d p gc c wi ht = case b of +drawBorder b lw d p gc c wi ht = case b of NoBorder -> return () - TopB -> drawBorder (TopBM 0) d p gc c w h - BottomB -> drawBorder (BottomBM 0) d p gc c w h - FullB -> drawBorder (FullBM 0) d p gc c w h - TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 - BottomBM m -> let rw = fi h - fi m in - sf >> drawLine d p gc 0 rw (fi w) rw - FullBM m -> let pad = 2 * fi m; mp = fi m in - sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) - where sf = setForeground d gc c - (w, h) = (wi - 1, ht - 1) + TopB -> drawBorder (TopBM 0) lw d p gc c wi ht + BottomB -> drawBorder (BottomBM 0) lw d p gc c wi ht + FullB -> drawBorder (FullBM 0) lw d p gc c wi ht + TopBM m -> sf >> sla >> drawLine d p gc 0 (fi m + boff) (fi wi) (fi m + boff) + BottomBM m -> let rw = fi ht - fi m + boff in + sf >> sla >> drawLine d p gc 0 rw (fi wi) rw + FullBM m -> let pad = 2 * fi m + 2 * fi boff'; mp = fi m + fi boff' in + sf >> sla >> drawRectangle d p gc mp mp (wi - pad) (ht - pad) + where sf = setForeground d gc c + sla = setLineAttributes d gc (fi lw) lineSolid capNotLast joinMiter + boff = borderOffset b lw + boff' = calcBorderOffset lw :: Int hideWindow :: Display -> Window -> IO () hideWindow d w = do @@ -185,5 +193,20 @@ showWindow r c d w = do sync d False isMapped :: Display -> Window -> IO Bool -isMapped d w = fmap ism $ getWindowAttributes d w +isMapped d w = ism <$> getWindowAttributes d w where ism (WindowAttributes { wa_map_state = wms }) = wms /= waIsUnmapped + +borderOffset :: (Integral a) => Border -> Int -> a +borderOffset b lw = + case b of + BottomB -> negate boffs + BottomBM _ -> negate boffs + TopB -> boffs + TopBM _ -> boffs + _ -> 0 + where boffs = calcBorderOffset lw + +calcBorderOffset :: (Integral a) => Int -> a +calcBorderOffset = ceiling . (/2) . toDouble + where toDouble = fi :: (Integral a) => a -> Double + diff --git a/src/XPMFile.hsc b/src/XPMFile.hsc new file mode 100644 index 0000000..f10449b --- /dev/null +++ b/src/XPMFile.hsc @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : XPMFile +-- Copyright : (C) 2014 Alexander Shabalin +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module XPMFile(readXPMFile) where + +#if MIN_VERSION_mtl(2, 2, 1) +import Control.Monad.Except(MonadError(..)) +#else +import Control.Monad.Error(MonadError(..)) +#endif +import Control.Monad.Trans(MonadIO(..)) +import Graphics.X11.Xlib(Dimension, Display(..), Drawable, Pixmap) +import Foreign.C.String(CString, withCString) +import Foreign.C.Types(CInt(..), CLong) +import Foreign.Ptr(Ptr) +import Foreign.Marshal.Alloc(alloca, allocaBytes) +import Foreign.Storable(peek, peekByteOff, pokeByteOff) + +#include <X11/xpm.h> + +foreign import ccall "XpmReadFileToPixmap" + xpmReadFileToPixmap :: Display -> Drawable -> CString -> Ptr Pixmap -> Ptr Pixmap -> Ptr () -> IO CInt + +readXPMFile + :: (MonadError String m, MonadIO m) + => Display + -> Drawable + -> String + -> m (Dimension, Dimension, Pixmap, Maybe Pixmap) +readXPMFile display d filename = + toError $ withCString filename $ \c_filename -> + alloca $ \pixmap_return -> + alloca $ \shapemask_return -> + allocaBytes (#size XpmAttributes) $ \attributes -> do + (#poke XpmAttributes, valuemask) attributes ((#const XpmReturnAllocPixels) :: CLong) + res <- xpmReadFileToPixmap display d c_filename pixmap_return shapemask_return attributes + case res of + 0 -> do + width <- (#peek XpmAttributes, width) attributes + height <- (#peek XpmAttributes, height) attributes + pixmap <- peek pixmap_return + shapemask <- peek shapemask_return + return $ Right (width, height, pixmap, if shapemask == 0 then Nothing else Just shapemask) + 1 -> return $ Left "readXPMFile: XpmColorError" + -1 -> return $ Left "readXPMFile: XpmOpenFailed" + -2 -> return $ Left "readXPMFile: XpmFileInvalid" + -3 -> return $ Left "readXPMFile: XpmNoMemory" + -4 -> return $ Left "readXPMFile: XpmColorFailed" + _ -> return $ Left "readXPMFile: Unknown error" + where toError m = either throwError return =<< liftIO m diff --git a/src/XUtil.hsc b/src/XUtil.hsc index c3bca7c..e333a22 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : XUtil --- Copyright : (C) 2011, 2012, 2013 Jose Antonio Ortega Ruiz +-- Copyright : (C) 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz -- (C) 2007 Andrea Rossato -- License : BSD3 -- @@ -102,7 +102,7 @@ hGetLineSafe = hGetLine data XFont = Core FontStruct | Utf8 FontSet #ifdef XFT - | Xft AXftFont + | Xft [AXftFont] #endif -- | When initFont gets a font name that starts with 'xft:' it switchs @@ -122,7 +122,7 @@ initFont d s = #endif miscFixedFont :: String -miscFixedFont = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" +miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. @@ -148,12 +148,22 @@ initUtf8Font d s = do fallBack = const $ createFontSet d miscFixedFont #ifdef XFT -initXftFont :: Display -> String -> IO AXftFont +initXftFont :: Display -> String -> IO [AXftFont] initXftFont d s = do setupLocale - f <- openAXftFont d (defaultScreenOfDisplay d) (drop 4 s) - addFinalizer f (closeAXftFont d f) - return f + let fontNames = wordsBy (== ',') (drop 4 s) + fonts <- mapM openFont fontNames + return fonts + where + openFont fontName = do + f <- openAXftFont d (defaultScreenOfDisplay d) fontName + addFinalizer f (closeAXftFont d f) + return f + wordsBy p str = case dropWhile p str of + "" -> [] + str' -> w : wordsBy p str'' + where + (w, str'') = break p str' #endif textWidth :: Display -> XFont -> String -> IO Int @@ -161,7 +171,7 @@ textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s #ifdef XFT textWidth dpy (Xft xftdraw) s = do - gi <- xftTxtExtents dpy xftdraw s + gi <- xftTxtExtents' dpy xftdraw s return $ xglyphinfo_xOff gi #endif @@ -175,9 +185,9 @@ textExtents (Utf8 fs) s = do descent = fi $ rect_height rl + (fi $ rect_y rl) return (ascent, descent) #ifdef XFT -textExtents (Xft xftfont) _ = do - ascent <- fi `fmap` xft_ascent xftfont - descent <- fi `fmap` xft_descent xftfont +textExtents (Xft xftfonts) _ = do + ascent <- fi `fmap` xft_ascent' xftfonts + descent <- fi `fmap` xft_descent' xftfonts return (ascent, descent) #endif @@ -185,21 +195,21 @@ printString :: Display -> Drawable -> XFont -> GC -> String -> String -> Position -> Position -> String -> IO () printString d p (Core fs) gc fc bc x y s = do setFont d gc $ fontFromFontStruct fs - withColors d [fc, bc] $ \[fc', bc'] -> do + withColors d [fc, bc] $ \[fc', _] -> do setForeground d gc fc' drawImageString d p gc x y s printString d p (Utf8 fs) gc fc bc x y s = - withColors d [fc, bc] $ \[fc', bc'] -> do + withColors d [fc, bc] $ \[fc', _] -> do setForeground d gc fc' io $ wcDrawImageString d p fs gc x y s #ifdef XFT -printString dpy drw fs@(Xft font) _ fc bc x y s = do +printString dpy drw fs@(Xft fonts) _ fc bc x y s = do (a,d) <- textExtents fs s - gi <- xftTxtExtents dpy font s + gi <- xftTxtExtents' dpy fonts s withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' -> - (drawXftString draw fc' font x (y - 2) s) + (drawXftString' draw fc' fonts (toInteger x) (toInteger (y - 2)) s) #endif diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 823b594..3016f75 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Xmobar @@ -36,13 +36,14 @@ import Graphics.X11.Xinerama import Graphics.X11.Xrandr import Control.Arrow ((&&&)) +import Control.Applicative ((<$>)) import Control.Monad.Reader import Control.Concurrent import Control.Concurrent.STM import Control.Exception (handle, SomeException(..)) import Data.Bits import Data.Map hiding (foldr, map, filter) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, isJust) import Foreign.Marshal.Alloc import Foreign.Storable import Foreign.Ptr @@ -125,7 +126,7 @@ startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do ConfigureEvent {} -> atomically $ putTMVar signal Reposition ExposeEvent {} -> atomically $ putTMVar signal Wakeup RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ putTMVar signal (Action (fi $ ev_x ev)) + ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) _ -> return () -- | Send signal to eventLoop every time a var is updated @@ -147,13 +148,13 @@ checker tvar ov vs signal = do -- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] -> XConf -> [(Action, Position, Position)] -> TMVar SignalType -> IO () +eventLoop :: TVar [String] -> XConf -> [([Action], Position, Position)] -> TMVar SignalType -> IO () eventLoop tv xc@(XConf d r w fs is cfg) as signal = do typ <- atomically $ takeTMVar signal case typ of Wakeup -> do str <- updateString cfg tv - xc' <- updateCache d w is str >>= \c -> return xc { iconS = c } + xc' <- updateCache d w is (iconRoot cfg) str >>= \c -> return xc { iconS = c } as' <- updateActions xc r str runX xc' $ drawInWin r str eventLoop tv xc' as' signal @@ -172,7 +173,7 @@ eventLoop tv xc@(XConf d r w fs is cfg) as signal = do TogglePersistent -> eventLoop tv xc { config = cfg { persistent = not $ persistent cfg } } as signal - Action x -> action x + Action but x -> action but x where isPersistent = not $ persistent cfg @@ -207,15 +208,20 @@ eventLoop tv xc@(XConf d r w fs is cfg) as signal = do case position ocfg of OnScreen n o -> do srs <- getScreenInfo d - if n == length srs then - return (ocfg {position = OnScreen 1 o}) - else - return (ocfg {position = OnScreen (n+1) o}) + return (if n == length srs + then + (ocfg {position = OnScreen 1 o}) + else + (ocfg {position = OnScreen (n+1) o})) o -> return (ocfg {position = OnScreen 1 o}) - action x = do mapM_ (\(a,_,_) -> runAction a) $ filter (\(_, from, to) -> x >= from && x <= to) as - eventLoop tv xc as signal + action button x = do + mapM_ runAction $ + filter (\(Spawn b _) -> button `elem` b) $ + concatMap (\(a,_,_) -> a) $ + filter (\(_, from, to) -> x >= from && x <= to) as + eventLoop tv xc as signal -- $command @@ -236,23 +242,24 @@ startCommand sig (com,s,ss) return (Just h,var) where is = s ++ "Updating..." ++ ss -updateString :: Config -> TVar [String] -> IO [[(Widget, String, Maybe Action)]] +updateString :: Config -> TVar [String] -> + IO [[(Widget, String, Maybe [Action])]] updateString conf v = do s <- atomically $ readTVar v let l:c:r:_ = s ++ repeat "" io $ mapM (parseString conf) [l, c, r] -updateActions :: XConf -> Rectangle -> [[(Widget, String, Maybe Action)]] -> - IO [(Action, Position, Position)] +updateActions :: XConf -> Rectangle -> [[(Widget, String, Maybe [Action])]] -> + IO [([Action], Position, Position)] updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do let (d,fs) = (display &&& fontS) conf - strLn :: [(Widget, String, Maybe Action)] -> IO [(Maybe Action, Position, Position)] + strLn :: [(Widget, String, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] strLn = io . mapM getCoords iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) getCoords (Text s,_,a) = textWidth d fs s >>= \tw -> return (a, 0, fi tw) getCoords (Icon s,_,a) = return (a, 0, fi $ iconW s) partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ - filter (\(a, _,_) -> a /= Nothing) $ + filter (\(a, _,_) -> isJust a) $ scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) (Nothing, 0, off) xs totSLen = foldr (\(_,_,len) -> (+) len) 0 @@ -263,13 +270,13 @@ updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do R -> remWidth xs L -> offs - fmap concat $ mapM (\(a,xs) -> fmap (\xs' -> partCoord (offset a xs') xs') $ strLn xs) $ + fmap concat $ mapM (\(a,xs) -> (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ zip [L,C,R] [left,center,right] -- $print -- | Draws in and updates the window -drawInWin :: Rectangle -> [[(Widget, String, Maybe Action)]] -> X () +drawInWin :: Rectangle -> [[(Widget, String, Maybe [Action])]] -> X () drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do r <- ask let (c,d ) = (config &&& display) r @@ -315,7 +322,7 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do printStrings p gc fs 1 R =<< strLn right printStrings p gc fs 1 C =<< strLn center -- draw 1 pixel border if requested - io $ drawBorder (border c) d p gc bdcolor wid ht + io $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht -- copy the pixmap with the new string to the window io $ copyArea d p w gc 0 0 wid ht 0 0 -- free up everything (we do not want to leak memory!) @@ -324,27 +331,39 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do -- resync io $ sync d True +verticalOffset :: (Integral b, Integral a, MonadIO m) => + a -> Widget -> XFont -> Config -> m b +verticalOffset ht (Text t) fontst conf + | textOffset conf > -1 = return $ fi (textOffset conf) + | otherwise = do + (as,ds) <- io $ textExtents fontst t + let bwidth = borderOffset (border conf) (borderWidth conf) + verticalMargin = (fi ht) - fi (as + ds) - 2 * fi (abs bwidth) + return $ (fi ht) - (fi ds) - (verticalMargin `div` 2) + bwidth + 1 +verticalOffset _ (Icon _) _ conf + | iconOffset conf > -1 = return $ fi (iconOffset conf) + | otherwise = do + let bwidth = borderOffset (border conf) (borderWidth conf) + return $ bwidth + 1 + -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> XFont -> Position -> Align -> [(Widget, String, Position)] -> X () printStrings _ _ _ _ _ [] = return () printStrings dr gc fontst offs a sl@((s,c,l):xs) = do r <- ask - (as,ds) <- case s of - Text t -> io $ textExtents fontst t - Icon _ -> return (0, 0) - let (conf,d) = (config &&& display) r + let (conf,d) = (config &&& display) r Rectangle _ _ wid ht = rect r - totSLen = foldr (\(_,_,len) -> (+) len) 0 sl - valign = -1 + (fi ht + fi (as + ds)) `div` 2 - remWidth = fi wid - fi totSLen - offset = case a of - C -> (remWidth + offs) `div` 2 - R -> remWidth - L -> offs - (fc,bc) = case break (==',') c of - (f,',':b) -> (f, b ) - (f, _) -> (f, bgColor conf) + totSLen = foldr (\(_,_,len) -> (+) len) 0 sl + remWidth = fi wid - fi totSLen + offset = case a of + C -> (remWidth + offs) `div` 2 + R -> remWidth + L -> offs + (fc,bc) = case break (==',') c of + (f,',':b) -> (f, b ) + (f, _) -> (f, bgColor conf) + valign <- verticalOffset ht s fontst conf case s of (Text t) -> io $ printString d dr fontst gc fc bc offset valign t (Icon p) -> io $ maybe (return ()) (drawBitmap d dr gc fc bc offset valign) (lookup p (iconS r)) |