summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Actions.hs17
-rw-r--r--src/Bitmap.hs82
-rw-r--r--src/ColorCache.hs4
-rw-r--r--src/Commands.hs2
-rw-r--r--src/Config.hs27
-rw-r--r--src/IPC/DBus.hs2
-rw-r--r--src/Localize.hsc2
-rw-r--r--src/Main.hs32
-rw-r--r--src/MinXft.hsc84
-rw-r--r--src/Parsers.hs117
-rw-r--r--src/Plugins/BufferedPipeReader.hs4
-rw-r--r--src/Plugins/Date.hs3
-rw-r--r--src/Plugins/DateZone.hs28
-rw-r--r--src/Plugins/EWMH.hs12
-rw-r--r--src/Plugins/Kbd.hsc3
-rw-r--r--src/Plugins/Locks.hs37
-rw-r--r--src/Plugins/MBox.hs13
-rw-r--r--src/Plugins/Mail.hs18
-rw-r--r--src/Plugins/MarqueePipeReader.hs68
-rw-r--r--src/Plugins/Monitors.hs22
-rw-r--r--src/Plugins/Monitors/Batt.hs75
-rw-r--r--src/Plugins/Monitors/Bright.hs52
-rw-r--r--src/Plugins/Monitors/CatInt.hs25
-rw-r--r--src/Plugins/Monitors/Common.hs146
-rw-r--r--src/Plugins/Monitors/CoreCommon.hs14
-rw-r--r--src/Plugins/Monitors/CoreTemp.hs20
-rw-r--r--src/Plugins/Monitors/Cpu.hs49
-rw-r--r--src/Plugins/Monitors/CpuFreq.hs32
-rw-r--r--src/Plugins/Monitors/Disk.hs109
-rw-r--r--src/Plugins/Monitors/MPD.hs54
-rw-r--r--src/Plugins/Monitors/Mem.hs73
-rw-r--r--src/Plugins/Monitors/Mpris.hs19
-rw-r--r--src/Plugins/Monitors/MultiCpu.hs70
-rw-r--r--src/Plugins/Monitors/Net.hs96
-rw-r--r--src/Plugins/Monitors/Swap.hs4
-rw-r--r--src/Plugins/Monitors/Thermal.hs13
-rw-r--r--src/Plugins/Monitors/ThermalZone.hs5
-rw-r--r--src/Plugins/Monitors/Top.hs11
-rw-r--r--src/Plugins/Monitors/Volume.hs54
-rw-r--r--src/Plugins/Monitors/Weather.hs139
-rw-r--r--src/Plugins/Monitors/Wireless.hs42
-rw-r--r--src/Plugins/PipeReader.hs17
-rw-r--r--src/Plugins/StdinReader.hs23
-rw-r--r--src/Plugins/XMonadLog.hs21
-rw-r--r--src/Signal.hs3
-rw-r--r--src/StatFS.hsc2
-rw-r--r--src/Window.hs67
-rw-r--r--src/XPMFile.hsc60
-rw-r--r--src/XUtil.hsc42
-rw-r--r--src/Xmobar.hs87
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))