diff options
| author | Pavan Rikhi <pavan.rikhi@gmail.com> | 2018-03-17 22:48:24 -0400 |
|---|---|---|
| committer | jao <jao@gnu.org> | 2018-11-21 21:41:35 +0000 |
| commit | 4d1402a1a7d87767267d48a77998e4fb13395b31 (patch) | |
| tree | 17fd6160dc1fa9c8a0676a94bcf8d19b551c655c /src/Xmobar | |
| parent | 9e2a5c7daddf683d4be7c318aefed3da3ea7a89a (diff) | |
| download | xmobar-4d1402a1a7d87767267d48a77998e4fb13395b31.tar.gz xmobar-4d1402a1a7d87767267d48a77998e4fb13395b31.tar.bz2 | |
Split Modules into Library & Executable Structure
Move the Main module to a new `app` directory. All other modules have
been nested under the `Xmobar` name. Lots of module headers & imports
were updated.
Diffstat (limited to 'src/Xmobar')
56 files changed, 7178 insertions, 0 deletions
diff --git a/src/Xmobar/Actions.hs b/src/Xmobar/Actions.hs new file mode 100644 index 0000000..7901845 --- /dev/null +++ b/src/Xmobar/Actions.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Actions +-- Copyright : (c) Alexander Polakov +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.Actions (Action(..), runAction, stripActions) where + +import System.Process (system) +import Control.Monad (void) +import Text.Regex (Regex, subRegex, mkRegex, matchRegex) +import Graphics.X11.Types (Button) + +data Action = Spawn [Button] String + deriving (Eq) + +runAction :: Action -> IO () +runAction (Spawn _ s) = void $ system (s ++ "&") + +stripActions :: String -> String +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/Xmobar/Bitmap.hs b/src/Xmobar/Bitmap.hs new file mode 100644 index 0000000..314ce02 --- /dev/null +++ b/src/Xmobar/Bitmap.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Bitmap +-- Copyright : (C) 2013, 2015, 2017, 2018 Alexander Polakov +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.Bitmap + ( updateCache + , drawBitmap + , Bitmap(..)) where + +import Control.Monad +import Control.Monad.Trans(MonadIO(..)) +import Data.Map hiding (map, filter) +import Graphics.X11.Xlib +import System.Directory (doesFileExist) +import System.FilePath ((</>)) +import System.Mem.Weak ( addFinalizer ) +import Xmobar.ColorCache +import Xmobar.Parsers (Widget(..)) +import Xmobar.Actions (Action) + +#ifdef XPM +import Xmobar.XPMFile(readXPMFile) +import Control.Applicative((<|>)) +#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 -> FilePath -> + [[(Widget, String, Int, 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 $ 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 +#ifdef XPM + res <- runExceptT (tryXBM <|> tryXPM) +#else + res <- runExceptT tryXBM +#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 () +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' + 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/Xmobar/ColorCache.hs b/src/Xmobar/ColorCache.hs new file mode 100644 index 0000000..f17aa0d --- /dev/null +++ b/src/Xmobar/ColorCache.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: ColorCache +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 00:27 +-- +-- +-- Caching X colors +-- +------------------------------------------------------------------------------ + +#if defined XFT + +module Xmobar.ColorCache(withColors, withDrawingColors) where + +import Xmobar.MinXft + +#else +module Xmobar.ColorCache(withColors) where + +#endif + +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Exception (SomeException, handle) +import Graphics.X11.Xlib + +data DynPixel = DynPixel Bool Pixel + +initColor :: Display -> String -> IO DynPixel +initColor dpy c = handle black $ initColor' dpy c + where + black :: SomeException -> IO DynPixel + black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy) + +type ColorCache = [(String, Color)] +{-# NOINLINE colorCache #-} +colorCache :: IORef ColorCache +colorCache = unsafePerformIO $ newIORef [] + +getCachedColor :: String -> IO (Maybe Color) +getCachedColor color_name = lookup color_name `fmap` readIORef colorCache + +putCachedColor :: String -> Color -> IO () +putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c + +initColor' :: Display -> String -> IO DynPixel +initColor' dpy c = do + let colormap = defaultColormap dpy (defaultScreen dpy) + cached_color <- getCachedColor c + c' <- case cached_color of + Just col -> return col + _ -> do (c'', _) <- allocNamedColor dpy colormap c + putCachedColor c c'' + return c'' + return $ DynPixel True (color_pixel c') + +withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a +withColors d cs f = do + ps <- mapM (liftIO . initColor d) cs + f $ map (\(DynPixel _ pixel) -> pixel) ps + +#ifdef XFT + +type AXftColorCache = [(String, AXftColor)] +{-# NOINLINE xftColorCache #-} +xftColorCache :: IORef AXftColorCache +xftColorCache = unsafePerformIO $ newIORef [] + +getXftCachedColor :: String -> IO (Maybe AXftColor) +getXftCachedColor name = lookup name `fmap` readIORef xftColorCache + +putXftCachedColor :: String -> AXftColor -> IO () +putXftCachedColor name cptr = + modifyIORef xftColorCache $ \c -> (name, cptr) : c + +initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor' d v cm c = do + cc <- getXftCachedColor c + c' <- case cc of + Just col -> return col + _ -> do c'' <- mallocAXftColor d v cm c + putXftCachedColor c c'' + return c'' + return c' + +initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) + where + black :: SomeException -> IO AXftColor + black = (const $ initAXftColor' d v cm "black") + +withDrawingColors :: -- MonadIO m => + Display -> Drawable -> String -> String + -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () +withDrawingColors dpy drw fc bc f = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + fc' <- initAXftColor dpy visual colormap fc + bc' <- initAXftColor dpy visual colormap bc + withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' +#endif diff --git a/src/Xmobar/Commands.hs b/src/Xmobar/Commands.hs new file mode 100644 index 0000000..ececdd9 --- /dev/null +++ b/src/Xmobar/Commands.hs @@ -0,0 +1,87 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Commands +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- The 'Exec' class and the 'Command' data type. +-- +-- The 'Exec' class rappresents the executable types, whose constructors may +-- appear in the 'Config.commands' field of the 'Config.Config' data type. +-- +-- The 'Command' data type is for OS commands to be run by xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Commands + ( Command (..) + , Exec (..) + , tenthSeconds + ) where + +import Prelude +import Control.Concurrent +import Control.Exception (handle, SomeException(..)) +import Data.Char +import System.Process +import System.Exit +import System.IO (hClose) + +import Xmobar.Signal +import Xmobar.XUtil + +class Show e => Exec e where + alias :: e -> String + alias e = takeWhile (not . isSpace) $ show e + rate :: e -> Int + rate _ = 10 + run :: e -> IO String + run _ = return "" + start :: e -> (String -> IO ()) -> IO () + start e cb = go + where go = run e >>= cb >> tenthSeconds (rate e) >> go + trigger :: e -> (Maybe SignalType -> IO ()) -> IO () + trigger _ sh = sh Nothing + +data Command = Com Program Args Alias Rate + | ComX Program Args String Alias Rate + deriving (Show,Read,Eq) + +type Args = [String] +type Program = String +type Alias = String +type Rate = Int + +instance Exec Command where + alias (ComX p _ _ a _) = + if p /= "" then (if a == "" then p else a) else "" + alias (Com p a al r) = alias (ComX p a "" al r) + start (Com p as al r) cb = + start (ComX p as ("Could not execute command " ++ p) al r) cb + start (ComX prog args msg _ r) cb = if r > 0 then go else exec + where go = exec >> tenthSeconds r >> go + exec = do + (i,o,e,p) <- runInteractiveProcess prog args Nothing Nothing + exit <- waitForProcess p + let closeHandles = hClose o >> hClose i >> hClose e + getL = handle (\(SomeException _) -> return "") + (hGetLineSafe o) + case exit of + ExitSuccess -> do str <- getL + closeHandles + cb str + _ -> closeHandles >> cb msg + + +-- | Work around to the Int max bound: since threadDelay takes an Int, it +-- is not possible to set a thread delay grater than about 45 minutes. +-- With a little recursion we solve the problem. +tenthSeconds :: Int -> IO () +tenthSeconds s | s >= x = do threadDelay (x * 100000) + tenthSeconds (s - x) + | otherwise = threadDelay (s * 100000) + where x = (maxBound :: Int) `div` 100000 diff --git a/src/Xmobar/Config.hs b/src/Xmobar/Config.hs new file mode 100644 index 0000000..21b29fa --- /dev/null +++ b/src/Xmobar/Config.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TypeOperators, CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Config +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- The configuration module of Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Xmobar.Config + ( -- * Configuration + -- $config + Config (..) + , XPosition (..), Align (..), Border(..) + , defaultConfig + , runnableTypes + ) where + + +import Xmobar.Commands +import {-# SOURCE #-} Xmobar.Runnable +import Xmobar.Plugins.Monitors +import Xmobar.Plugins.Date +import Xmobar.Plugins.PipeReader +import Xmobar.Plugins.BufferedPipeReader +import Xmobar.Plugins.MarqueePipeReader +import Xmobar.Plugins.CommandReader +import Xmobar.Plugins.StdinReader +import Xmobar.Plugins.XMonadLog +import Xmobar.Plugins.EWMH +import Xmobar.Plugins.Kbd +import Xmobar.Plugins.Locks + +#ifdef INOTIFY +import Xmobar.Plugins.Mail +import Xmobar.Plugins.MBox +#endif + +#ifdef DATEZONE +import Xmobar.Plugins.DateZone +#endif + +-- $config +-- Configuration data type and default configuration + +-- | The configuration data type +data Config = + Config { font :: String -- ^ Font + , additionalFonts :: [String] -- ^ List of alternative fonts + , wmClass :: String -- ^ X11 WM_CLASS property value + , wmName :: String -- ^ X11 WM_NAME property value + , bgColor :: String -- ^ Backgroud color + , fgColor :: String -- ^ Default font color + , position :: XPosition -- ^ Top Bottom or Static + , textOffset :: Int -- ^ Offset from top of window for text + , textOffsets :: [Int] -- ^ List of offsets for additionalFonts + , 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 + -- to run (optional) + , sepChar :: String -- ^ The character to be used for indicating + -- commands in the output template + -- (default '%') + , alignSep :: String -- ^ Separators for left, center and + -- right text alignment + , template :: String -- ^ The output template + } deriving (Read) + +data XPosition = Top + | TopW Align Int + | TopSize Align Int Int + | TopP Int Int + | Bottom + | BottomP Int Int + | BottomW Align Int + | BottomSize Align Int Int + | Static {xpos, ypos, width, height :: Int} + | OnScreen Int XPosition + deriving ( Read, Eq ) + +data Align = L | R | C deriving ( Read, Eq ) + +data Border = NoBorder + | TopB + | BottomB + | FullB + | TopBM Int + | BottomBM Int + | FullBM Int + deriving ( Read, Eq ) + +-- | The default configuration values +defaultConfig :: Config +defaultConfig = + Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , additionalFonts = [] + , wmClass = "xmobar" + , wmName = "xmobar" + , bgColor = "#000000" + , fgColor = "#BFBFBF" + , alpha = 255 + , position = Top + , border = NoBorder + , borderColor = "#BFBFBF" + , borderWidth = 1 + , textOffset = -1 + , iconOffset = -1 + , textOffsets = [] + , 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 = "%" + , alignSep = "}{" + , template = "%StdinReader% }{ " ++ + "<fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>" + } + + +-- | An alias for tuple types that is more convenient for long lists. +type a :*: b = (a, b) +infixr :*: + +-- | This is the list of types that can be hidden inside +-- 'Runnable.Runnable', the existential type that stores all commands +-- to be executed by Xmobar. It is used by 'Runnable.readRunnable' in +-- the 'Runnable.Runnable' Read instance. To install a plugin just add +-- 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 + MarqueePipeReader :*: () +runnableTypes = undefined diff --git a/src/Xmobar/Environment.hs b/src/Xmobar/Environment.hs new file mode 100644 index 0000000..8a9223a --- /dev/null +++ b/src/Xmobar/Environment.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMobar.Environment +-- Copyright : (c) William Song +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Will Song <incertia@incertia.net> +-- Stability : stable +-- Portability : portable +-- +-- A function to expand environment variables in strings +-- +----------------------------------------------------------------------------- +module Xmobar.Environment(expandEnv) where + +import Control.Applicative ((<$>)) +import Data.Maybe (fromMaybe) +import System.Environment (lookupEnv) + +expandEnv :: String -> IO String +expandEnv "" = return "" +expandEnv (c:s) = case c of + '$' -> do + envVar <- fromMaybe "" <$> lookupEnv e + remainder <- expandEnv s' + return $ envVar ++ remainder + where (e, s') = getVar s + getVar "" = ("", "") + getVar ('{':s'') = (takeUntil "}" s'', drop 1 . dropUntil "}" $ s'') + getVar s'' = (takeUntil filterstr s'', dropUntil filterstr s'') + filterstr = ",./? \t;:\"'~`!@#$%^&*()<>-+=\\|" + takeUntil f = takeWhile (not . flip elem f) + dropUntil f = dropWhile (not . flip elem f) + + '\\' -> case s == "" of + True -> return "\\" + False -> do + remainder <- expandEnv $ drop 1 s + return $ escString s ++ remainder + where escString s' = let (cc:_) = s' in + case cc of + 't' -> "\t" + 'n' -> "\n" + '$' -> "$" + _ -> [cc] + + _ -> do + remainder <- expandEnv s + return $ c : remainder diff --git a/src/Xmobar/IPC/DBus.hs b/src/Xmobar/IPC/DBus.hs new file mode 100644 index 0000000..894637b --- /dev/null +++ b/src/Xmobar/IPC/DBus.hs @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DBus +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> +-- Stability : unstable +-- Portability : unportable +-- +-- DBus IPC module for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.IPC.DBus (runIPC) where + +import DBus +import DBus.Client hiding (interfaceName) +import qualified DBus.Client as DC +import Data.Maybe (isNothing) +import Control.Concurrent.STM +import Control.Exception (handle) +import System.IO (stderr, hPutStrLn) +import Control.Monad.IO.Class (liftIO) + +import Xmobar.Signal + +busName :: BusName +busName = busName_ "org.Xmobar.Control" + +objectPath :: ObjectPath +objectPath = objectPath_ "/org/Xmobar/Control" + +interfaceName :: InterfaceName +interfaceName = interfaceName_ "org.Xmobar.Control" + +runIPC :: TMVar SignalType -> IO () +runIPC mvst = handle printException exportConnection + where + printException :: ClientError -> IO () + printException = hPutStrLn stderr . clientErrorMessage + exportConnection = do + client <- connectSession + requestName client busName [ nameDoNotQueue ] + export client objectPath defaultInterface + { DC.interfaceName = interfaceName + , DC.interfaceMethods = [ sendSignalMethod mvst ] + } + +sendSignalMethod :: TMVar SignalType -> Method +sendSignalMethod mvst = makeMethod sendSignalName + (signature_ [variantType $ toVariant (undefined :: SignalType)]) + (signature_ []) + sendSignalMethodCall + where + sendSignalName :: MemberName + sendSignalName = memberName_ "SendSignal" + + sendSignalMethodCall :: MethodCall -> DBusR Reply + sendSignalMethodCall mc = liftIO $ + if methodCallMember mc == sendSignalName + then do + let signals :: [Maybe SignalType] + signals = map fromVariant (methodCallBody mc) + mapM_ sendSignal signals + if any isNothing signals + then return ( ReplyError errorInvalidParameters [] ) + else return ( ReplyReturn [] ) + else + return ( ReplyError errorUnknownMethod [] ) + + sendSignal :: Maybe SignalType -> IO () + sendSignal = maybe (return ()) (atomically . putTMVar mvst) diff --git a/src/Xmobar/Localize.hsc b/src/Xmobar/Localize.hsc new file mode 100644 index 0000000..984aa2b --- /dev/null +++ b/src/Xmobar/Localize.hsc @@ -0,0 +1,89 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Localize +-- Copyright : (C) 2011 Martin Perner +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Martin Perner <martin@perner.cc> +-- Stability : unstable +-- Portability : unportable +-- +-- This module provides an interface to locale information e.g. for DateL +-- +----------------------------------------------------------------------------- + +module Xmobar.Localize + ( setupTimeLocale, + getTimeLocale + ) where + +import Foreign.C +#if ! MIN_VERSION_time(1,5,0) +import qualified System.Locale as L +#else +import qualified Data.Time.Format as L +#endif + +#ifdef UTF8 +import Codec.Binary.UTF8.String +#endif + +-- get localized strings +type NlItem = CInt + +#include <langinfo.h> +foreign import ccall unsafe "langinfo.h nl_langinfo" + nl_langinfo :: NlItem -> IO CString + +#{enum NlItem, + , AM_STR , PM_STR \ + , D_T_FMT , D_FMT , T_FMT , T_FMT_AMPM \ + , ABDAY_1, ABDAY_7 \ + , DAY_1, DAY_7 \ + , ABMON_1, ABMON_12 \ + , MON_1, MON_12\ + } + +getLangInfo :: NlItem -> IO String +getLangInfo item = do + itemStr <- nl_langinfo item +#ifdef UTF8 + str <- peekCString itemStr + return $ if isUTF8Encoded str then decodeString str else str +#else + peekCString itemStr +#endif + +#include <locale.h> +foreign import ccall unsafe "locale.h setlocale" + setlocale :: CInt -> CString -> IO CString + +setupTimeLocale :: String -> IO () +setupTimeLocale l = withCString l (setlocale #const LC_TIME) >> return () + +getTimeLocale :: IO L.TimeLocale +getTimeLocale = do + -- assumes that the defined values are increasing by exactly one. + -- as they are defined consecutive in an enum this is reasonable + days <- mapM getLangInfo [day1 .. day7] + abdays <- mapM getLangInfo [abday1 .. abday7] + + mons <- mapM getLangInfo [mon1 .. mon12] + abmons <- mapM getLangInfo [abmon1 .. abmon12] + + amstr <- getLangInfo amStr + pmstr <- getLangInfo pmStr + dtfmt <- getLangInfo dTFmt + dfmt <- getLangInfo dFmt + tfmt <- getLangInfo tFmt + tfmta <- getLangInfo tFmtAmpm + + let t = L.defaultTimeLocale {L.wDays = zip days abdays + ,L.months = zip mons abmons + ,L.amPm = (amstr, pmstr) + ,L.dateTimeFmt = dtfmt + ,L.dateFmt = dfmt + ,L.timeFmt = tfmt + ,L.time12Fmt = tfmta} + return t diff --git a/src/Xmobar/MinXft.hsc b/src/Xmobar/MinXft.hsc new file mode 100644 index 0000000..0bf36c7 --- /dev/null +++ b/src/Xmobar/MinXft.hsc @@ -0,0 +1,333 @@ +------------------------------------------------------------------------------ +-- | +-- Module: MinXft +-- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz +-- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007 +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 18:12 +-- +-- +-- Pared down Xft library, based on Graphics.X11.Xft and providing +-- explicit management of XftColors, so that they can be cached. +-- +-- Most of the code is lifted from Clemens's. +-- +------------------------------------------------------------------------------ + +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module Xmobar.MinXft ( AXftColor + , AXftDraw (..) + , AXftFont + , mallocAXftColor + , freeAXftColor + , withAXftDraw + , drawXftString + , drawXftString' + , drawBackground + , drawXftRect + , openAXftFont + , closeAXftFont + , xftTxtExtents + , xftTxtExtents' + , xft_ascent + , xft_ascent' + , xft_descent + , xft_descent' + , xft_height + , xft_height' + ) + +where + +import Graphics.X11 +import Graphics.X11.Xlib.Types +import Graphics.X11.Xrender +import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree) + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Codec.Binary.UTF8.String as UTF8 +import Data.Char (ord) + +import Control.Monad (when) + +#include <X11/Xft/Xft.h> + +-- Color Handling + +newtype AXftColor = AXftColor (Ptr AXftColor) + +foreign import ccall "XftColorAllocName" + cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool) + +-- this is the missing bit in X11.Xft, not implementable from the +-- outside because XftColor does not export a constructor. +mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +mallocAXftColor d v cm n = do + color <- mallocBytes (#size XftColor) + withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color) + return (AXftColor color) + +foreign import ccall "XftColorFree" + freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO () + +-- Font handling + +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 () + +xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo +xftTxtExtents d f string = + withArrayLen (map fi (UTF8.encode string)) $ + \len str_ptr -> alloca $ + \cglyph -> do + 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 + +openAXftFont :: Display -> Screen -> String -> IO AXftFont +openAXftFont dpy screen name = + withCAString name $ + \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname + +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 +fi = fromIntegral + +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 () + +withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a +withAXftDraw d p v c act = do + draw <- c_xftDrawCreate d p v c + a <- act draw + c_xftDrawDestroy draw + return a + +foreign import ccall "XftDrawStringUtf8" + cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO () + +drawXftString :: (Integral a1, Integral a) => + AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO () +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] -> String -> + 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 () + +drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) => + AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO () +drawXftRect draw color x y width height = + cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height) + +#include <X11/extensions/Xrender.h> + +type Picture = XID +type PictOp = CInt + +data XRenderPictFormat +data XRenderPictureAttributes = XRenderPictureAttributes + +-- foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle" + -- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO () +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite" + xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO () +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill" + xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture" + xRenderFreePicture :: Display -> Picture -> IO () +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat" + xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat) +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture" + xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture + + +-- Attributes not supported +instance Storable XRenderPictureAttributes where + sizeOf _ = #{size XRenderPictureAttributes} + alignment _ = alignment (undefined :: CInt) + peek _ = return XRenderPictureAttributes + poke p XRenderPictureAttributes = + memset p 0 #{size XRenderPictureAttributes} + +-- | Convenience function, gives us an XRender handle to a traditional +-- Pixmap. Don't let it escape. +withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO () +withRenderPicture d p f = do + format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24 + alloca $ \attr -> do + pic <- xRenderCreatePicture d p format 0 attr + f pic + xRenderFreePicture d pic + +-- | Convenience function, gives us an XRender picture that is a solid +-- fill of color 'c'. Don't let it escape. +withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO () +withRenderFill d c f = do + pic <- with c (xRenderCreateSolidFill d) + f pic + xRenderFreePicture d pic + +-- | Drawing the background to a pixmap and taking into account +-- transparency +drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO () +drawBackground d p bgc alpha (Rectangle x y wid ht) = do + let render opt bg pic m = + xRenderComposite d opt bg m pic + (fromIntegral x) (fromIntegral y) 0 0 + 0 0 (fromIntegral wid) (fromIntegral ht) + withRenderPicture d p $ \pic -> do + -- Handle background color + bgcolor <- parseRenderColor d bgc + withRenderFill d bgcolor $ \bgfill -> + withRenderFill d + (XRenderColor 0 0 0 (257 * alpha)) + (render pictOpSrc bgfill pic) + -- Handle transparency + internAtom d "_XROOTPMAP_ID" False >>= \xid -> + let xroot = defaultRootWindow d in + alloca $ \x1 -> + alloca $ \x2 -> + alloca $ \x3 -> + alloca $ \x4 -> + alloca $ \pprop -> do + xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop + prop <- peek pprop + when (prop /= nullPtr) $ do + rootbg <- peek (castPtr prop) :: IO Pixmap + xFree prop + withRenderPicture d rootbg $ \bgpic -> + withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha)) + (render pictOpAdd bgpic pic) + +-- | Parses color into XRender color (allocation not necessary!) +parseRenderColor :: Display -> String -> IO XRenderColor +parseRenderColor d c = do + let colormap = defaultColormap d (defaultScreen d) + Color _ red green blue _ <- parseColor d colormap c + return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF + +pictOpSrc, pictOpAdd :: PictOp +pictOpSrc = 1 +pictOpAdd = 12 + +-- pictOpMinimum = 0 +-- pictOpClear = 0 +-- pictOpDst = 2 +-- pictOpOver = 3 +-- pictOpOverReverse = 4 +-- pictOpIn = 5 +-- pictOpInReverse = 6 +-- pictOpOut = 7 +-- pictOpOutReverse = 8 +-- pictOpAtop = 9 +-- pictOpAtopReverse = 10 +-- pictOpXor = 11 +-- pictOpSaturate = 13 +-- pictOpMaximum = 13 diff --git a/src/Xmobar/Parsers.hs b/src/Xmobar/Parsers.hs new file mode 100644 index 0000000..d76f8f7 --- /dev/null +++ b/src/Xmobar/Parsers.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Parsers +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Parsers needed for Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Xmobar.Parsers + ( parseString + , parseTemplate + , parseConfig + , Widget(..) + ) where + +import Xmobar.Config +import Xmobar.Runnable +import Xmobar.Commands +import Xmobar.Actions + +import Control.Monad (guard, mzero) +import qualified Data.Map as Map +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Number (int) +import Text.ParserCombinators.Parsec.Perm +import Graphics.X11.Types (Button) + +data Widget = Icon String | Text String + +type ColorString = String +type FontIndex = Int + +-- | Runs the string parser +parseString :: Config -> String -> IO [(Widget, ColorString, FontIndex, Maybe [Action])] +parseString c s = + case parse (stringParser (fgColor c) 0 Nothing) "" s of + Left _ -> return [(Text $ "Could not parse string: " ++ s + , fgColor c + , 0 + , Nothing)] + Right x -> return (concat x) + +allParsers :: ColorString + -> FontIndex + -> Maybe [Action] + -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +allParsers c f a = + textParser c f a + <|> try (iconParser c f a) + <|> try (rawParser c f a) + <|> try (actionParser c f a) + <|> try (fontParser c a) + <|> colorParser f a + +-- | Gets the string and combines the needed parsers +stringParser :: String -> FontIndex -> Maybe [Action] + -> Parser [[(Widget, ColorString, FontIndex, Maybe [Action])]] +stringParser c f a = manyTill (allParsers c f a) eof + +-- | Parses a maximal string without color markup. +textParser :: String -> FontIndex -> Maybe [Action] + -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +textParser c f a = do s <- many1 $ + noneOf "<" <|> + try (notFollowedBy' (char '<') + (try (string "fc=") <|> + try (string "fn=") <|> + try (string "action=") <|> + try (string "/action>") <|> + try (string "icon=") <|> + try (string "raw=") <|> + try (string "/fn>") <|> + string "/fc>")) + return [(Text s, c, f, 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 + -> FontIndex + -> Maybe [Action] + -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +rawParser c f 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, f, 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 +-- accepts only parsers with return type Char. +notFollowedBy' :: Parser a -> Parser b -> Parser a +notFollowedBy' p e = do x <- p + notFollowedBy $ try (e >> return '*') + return x + +iconParser :: String -> FontIndex -> Maybe [Action] + -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +iconParser c f a = do + string "<icon=" + i <- manyTill (noneOf ">") (try (string "/>")) + return [(Icon i, c, f, a)] + +actionParser :: String -> FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +actionParser c f 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 f a') (try $ string "</action>") + return (concat s) + +toButtons :: String -> [Button] +toButtons = map (\x -> read [x]) + +-- | Parsers a string wrapped in a color specification. +colorParser :: FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +colorParser f a = do + c <- between (string "<fc=") (string ">") colors + s <- manyTill (allParsers c f a) (try $ string "</fc>") + return (concat s) + +-- | Parsers a string wrapped in a font specification. +fontParser :: ColorString -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +fontParser c a = do + f <- between (string "<fn=") (string ">") colors + s <- manyTill (allParsers c (read f) a) (try $ string "</fn>") + return (concat s) + +-- | Parses a color specification (hex or named) +colors :: Parser String +colors = many1 (alphaNum <|> char ',' <|> char '#') + +-- | Parses the output template string +templateStringParser :: Config -> Parser (String,String,String) +templateStringParser c = do + s <- allTillSep c + com <- templateCommandParser c + ss <- allTillSep c + return (com, s, ss) + +-- | Parses the command part of the template string +templateCommandParser :: Config -> Parser String +templateCommandParser c = + let chr = char . head . sepChar + in between (chr c) (chr c) (allTillSep c) + +-- | Combines the template parsers +templateParser :: Config -> Parser [(String,String,String)] +templateParser = many . templateStringParser + +-- | Actually runs the template parsers +parseTemplate :: Config -> String -> IO [(Runnable,String,String)] +parseTemplate c s = + do str <- case parse (templateParser c) "" s of + Left _ -> return [("", s, "")] + Right x -> return x + let cl = map alias (commands c) + m = Map.fromList $ zip cl (commands c) + return $ combine c m str + +-- | Given a finite "Map" and a parsed template produce the resulting +-- output string. +combine :: Config -> Map.Map String Runnable + -> [(String, String, String)] -> [(Runnable,String,String)] +combine _ _ [] = [] +combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs + where com = Map.findWithDefault dflt ts m + dflt = Run $ Com ts [] [] 10 + +allTillSep :: Config -> Parser String +allTillSep = many . noneOf . sepChar + +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 ('"':xs) = '"': strip (not m) xs + strip m (x:xs) = x : strip m xs + strip _ [] = [] + +-- | Parse the config, logging a list of fields that were missing and replaced +-- by the default definition. +parseConfig :: String -> Either ParseError (Config,[String]) +parseConfig = runParser parseConf fields "Config" . stripComments + where + parseConf = do + many space + sepEndSpc ["Config","{"] + x <- perms + eof + s <- getState + return (x,s) + + perms = permute $ Config + <$?> pFont <|?> pFontList <|?> pWmClass <|?> pWmName + <|?> pBgColor <|?> pFgColor + <|?> pPosition <|?> pTextOffset <|?> pTextOffsets + <|?> pIconOffset <|?> pBorder + <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart + <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest + <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot + <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate + + + fields = [ "font", "additionalFonts","bgColor", "fgColor" + , "wmClass", "wmName", "sepChar" + , "alignSep" , "border", "borderColor" ,"template" + , "position" , "textOffset", "textOffsets", "iconOffset" + , "allDesktops", "overrideRedirect", "pickBroadest" + , "hideOnStart", "lowerOnStart", "persistent", "iconRoot" + , "alpha", "commands" + ] + + pFont = strField font "font" + pFontList = strListField additionalFonts "additionalFonts" + pWmClass = strField wmClass "wmClass" + pWmName = strField wmName "wmName" + pBgColor = strField bgColor "bgColor" + pFgColor = strField fgColor "fgColor" + pBdColor = strField borderColor "borderColor" + pSepChar = strField sepChar "sepChar" + pAlignSep = strField alignSep "alignSep" + pTemplate = strField template "template" + + pTextOffset = readField textOffset "textOffset" + pTextOffsets = readIntList textOffsets "textOffsets" + 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 + + staticPos = do string "Static" + wrapSkip (string "{") + p <- many (noneOf "}") + wrapSkip (string "}") + string "," + return ("Static {" ++ p ++ "}") + tillFieldEnd = staticPos <|> many (noneOf ",}\n\r") + + commandsEnd = wrapSkip (string "]") >> (string "}" <|> notNextRun) + notNextRun = do {string "," + ; notFollowedBy $ wrapSkip $ string "Run" + ; return "," + } + readCommands = manyTill anyChar (try commandsEnd) >>= + read' commandsErr . flip (++) "]" + strField e n = field e n strMulti + + strMulti = scan '"' + where + scan lead = do + spaces + char lead + s <- manyTill anyChar (rowCont <|> unescQuote) + (char '"' >> return s) <|> fmap (s ++) (scan '\\') + rowCont = try $ char '\\' >> string "\n" + unescQuote = lookAhead (noneOf "\\") >> lookAhead (string "\"") + + strListField e n = field e n strList + strList = do + spaces + char '[' + list <- sepBy (strMulti >>= \x -> spaces >> return x) (char ',') + spaces + char ']' + return list + + wrapSkip x = many space >> x >>= \r -> many space >> return r + sepEndSpc = mapM_ (wrapSkip . try . string) + fieldEnd = many $ space <|> oneOf ",}" + field e n c = (,) (e defaultConfig) $ + updateState (filter (/= n)) >> sepEndSpc [n,"="] >> + wrapSkip c >>= \r -> fieldEnd >> return r + readField a n = field a n $ tillFieldEnd >>= read' n + + readIntList d n = field d n intList + intList = do + spaces + char '[' + list <- sepBy (spaces >> int >>= \x-> spaces >> return x) (char ',') + spaces + char ']' + return list + + read' d s = case reads s of + [(x, _)] -> return x + _ -> fail $ "error reading the " ++ d ++ " field: " ++ s + +commandsErr :: String +commandsErr = "commands: this usually means that a command could not" ++ + "\nbe parsed." ++ + "\nThe error could be located at the begining of the command" ++ + "\nwhich follows the offending one." diff --git a/src/Xmobar/Plugins.hs b/src/Xmobar/Plugins.hs new file mode 100644 index 0000000..75ee306 --- /dev/null +++ b/src/Xmobar/Plugins.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Plugins +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- This module exports the API for plugins. +-- +-- Have a look at Plugins\/HelloWorld.hs +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins + ( Exec (..) + , tenthSeconds + , readFileSafe + , hGetLineSafe + ) where + +import Xmobar.Commands +import Xmobar.XUtil diff --git a/src/Xmobar/Plugins/BufferedPipeReader.hs b/src/Xmobar/Plugins/BufferedPipeReader.hs new file mode 100644 index 0000000..d4d30a1 --- /dev/null +++ b/src/Xmobar/Plugins/BufferedPipeReader.hs @@ -0,0 +1,87 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.BufferedPipeReader +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading (temporarily) from named pipes with reset +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.BufferedPipeReader where + +import Control.Monad(forM_, when, void) +import Control.Concurrent +import Control.Concurrent.STM +import System.IO +import System.IO.Unsafe(unsafePerformIO) + +import Xmobar.Environment +import Xmobar.Plugins +import Xmobar.Signal + +data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] + deriving (Read, Show) + +{-# NOINLINE signal #-} +signal :: MVar SignalType +signal = unsafePerformIO newEmptyMVar + +instance Exec BufferedPipeReader where + alias ( BufferedPipeReader a _ ) = a + + trigger br@( BufferedPipeReader _ _ ) sh = + takeMVar signal >>= sh . Just >> trigger br sh + + start ( BufferedPipeReader _ ps ) cb = do + + (chan, str, rst) <- initV + forM_ ps $ \p -> forkIO $ reader p chan + writer chan str rst + + where + initV :: IO ( TChan (Int, Bool, String), TVar (Maybe String), TVar Bool ) + initV = atomically $ do + tc <- newTChan + ts <- newTVar Nothing + tb <- newTVar False + return (tc, ts, tb) + + reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () + reader p@(to, tg, fp) tc = do + fp' <- expandEnv fp + openFile fp' ReadWriteMode >>= hGetLineSafe >>= \dt -> + atomically $ writeTChan tc (to, tg, dt) + reader p tc + + writer :: TChan (Int, Bool, String) + -> TVar (Maybe String) -> TVar Bool -> IO () + writer tc ts otb = do + (to, tg, dt, ntb) <- update + cb dt + when tg $ putMVar signal $ Reveal 0 + when (to /= 0) $ sfork $ reset to tg ts ntb + writer tc ts ntb + + where + sfork :: IO () -> IO () + sfork f = void (forkIO f) + + update :: IO (Int, Bool, String, TVar Bool) + update = atomically $ do + (to, tg, dt) <- readTChan tc + when (to == 0) $ writeTVar ts $ Just dt + writeTVar otb False + tb <- newTVar True + return (to, tg, dt, tb) + + reset :: Int -> Bool -> TVar (Maybe String) -> TVar Bool -> IO () + reset to tg ts tb = do + threadDelay ( to * 100 * 1000 ) + readTVarIO tb >>= \b -> when b $ do + when tg $ putMVar signal $ Hide 0 + readTVarIO ts >>= maybe (return ()) cb diff --git a/src/Xmobar/Plugins/CommandReader.hs b/src/Xmobar/Plugins/CommandReader.hs new file mode 100644 index 0000000..80b6299 --- /dev/null +++ b/src/Xmobar/Plugins/CommandReader.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.CommandReader +-- Copyright : (c) John Goerzen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from external commands +-- note: stderr is lost here +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.CommandReader where + +import System.IO +import Xmobar.Plugins +import System.Process(runInteractiveCommand, getProcessExitCode) + +data CommandReader = CommandReader String String + deriving (Read, Show) + +instance Exec CommandReader where + alias (CommandReader _ a) = a + start (CommandReader p _) cb = do + (hstdin, hstdout, hstderr, ph) <- runInteractiveCommand p + hClose hstdin + hClose hstderr + hSetBinaryMode hstdout False + hSetBuffering hstdout LineBuffering + forever ph (hGetLineSafe hstdout >>= cb) + where forever ph a = + do a + ec <- getProcessExitCode ph + case ec of + Nothing -> forever ph a + Just _ -> cb "EXITED" diff --git a/src/Xmobar/Plugins/Date.hs b/src/Xmobar/Plugins/Date.hs new file mode 100644 index 0000000..fdc6a56 --- /dev/null +++ b/src/Xmobar/Plugins/Date.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Date +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A date plugin for Xmobar +-- +-- Usage example: in template put +-- +-- > Run Date "%a %b %_d %Y <fc=#ee9a00> %H:%M:%S</fc>" "Mydate" 10 +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Date (Date(..)) where + +import Xmobar.Plugins + +#if ! MIN_VERSION_time(1,5,0) +import System.Locale +#endif +import Data.Time + +data Date = Date String String Int + deriving (Read, Show) + +instance Exec Date where + alias (Date _ a _) = a + run (Date f _ _) = date f + rate (Date _ _ r) = r + +date :: String -> IO String +date format = fmap (formatTime defaultTimeLocale format) getZonedTime diff --git a/src/Xmobar/Plugins/DateZone.hs b/src/Xmobar/Plugins/DateZone.hs new file mode 100644 index 0000000..753f530 --- /dev/null +++ b/src/Xmobar/Plugins/DateZone.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.DateZone +-- Copyright : (c) Martin Perner +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Martin Perner <martin@perner.cc> +-- Stability : unstable +-- Portability : unportable +-- +-- A date plugin with localization and location support for Xmobar +-- +-- Based on Plugins.Date +-- +-- Usage example: in template put +-- +-- > Run DateZone "%a %H:%M:%S" "de_DE.UTF-8" "UTC" "utcDate" 10 +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.DateZone (DateZone(..)) where + +import Xmobar.Plugins + + +#ifdef DATEZONE +import Control.Concurrent.STM + +import System.IO.Unsafe + +import Xmobar.Localize +import Data.Time.Format +import Data.Time.LocalTime +import Data.Time.LocalTime.TimeZone.Olson +import Data.Time.LocalTime.TimeZone.Series + +#if ! MIN_VERSION_time(1,5,0) +import System.Locale (TimeLocale) +#endif +#else +import System.IO +import Xmobar.Plugins.Date +#endif + + + +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 + locale <- getTimeLocale + atomically $ putTMVar localeLock lock + if z /= "" then do + timeZone <- getTimeZoneSeriesFromOlsonFile ("/usr/share/zoneinfo/" ++ z) + go (dateZone f locale timeZone) + else + go (date f locale) + + 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 + +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/Xmobar/Plugins/EWMH.hs b/src/Xmobar/Plugins/EWMH.hs new file mode 100644 index 0000000..363ec90 --- /dev/null +++ b/src/Xmobar/Plugins/EWMH.hs @@ -0,0 +1,265 @@ +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE CPP, NamedFieldPuns, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.EWMH +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- An experimental plugin to display EWMH pager information +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.EWMH (EWMH(..)) where + +import Control.Applicative (Applicative(..)) +import Control.Monad.State +import Control.Monad.Reader +import Graphics.X11 hiding (Modifier, Color) +import Graphics.X11.Xlib.Extras +import Xmobar.Plugins +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar, CLong) +import Xmobar.XUtil (nextEvent') + +import Data.List (intersperse, intercalate) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +data EWMH = EWMH | EWMHFMT Component deriving (Read, Show) + +instance Exec EWMH where + alias EWMH = "EWMH" + + start ew cb = allocaXEvent $ \ep -> execM $ do + d <- asks display + r <- asks root + + liftIO xSetErrorHandler + + liftIO $ selectInput d r propertyChangeMask + handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers + mapM_ ((=<< asks root) . snd) handlers' + + forever $ do + liftIO . cb . fmtOf ew =<< get + liftIO $ nextEvent' d ep + e <- liftIO $ getEvent ep + case e of + PropertyEvent { ev_atom = a, ev_window = w } -> + case lookup a handlers' of + Just f -> f w + _ -> return () + _ -> return () + + return () + +defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty] + , Layout + , Color "#00ee00" "" :$ Short 120 :$ WindowName] + +fmtOf EWMH = flip fmt defaultPP +fmtOf (EWMHFMT f) = flip fmt f + +sep :: [a] -> [[a]] -> [a] +sep x xs = intercalate x $ filter (not . null) xs + +fmt :: EwmhState -> Component -> String +fmt e (Text s) = s +fmt e (l :+ r) = fmt e l ++ fmt e r +fmt e (m :$ r) = modifier m $ fmt e r +fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs +fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e) +fmt e Layout = layout e +fmt e (Workspaces opts) = sep " " + [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as] + | (n, as) <- attrs] + where + stats i = [ (Current, i == currentDesktop e) + , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e) + -- TODO for visible , (Visibl + ] + attrs :: [(String, [WsType])] + 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 Hide = const "" +modifier (Color fg bg) = \x -> concat ["<fc=", fg, if null bg then "" else "," ++ bg + , ">", x, "</fc>"] +modifier (Short n) = take n +modifier (Wrap l r) = \x -> l ++ x ++ r + +data Component = Text String + | Component :+ Component + | Modifier :$ Component + | Sep Component [Component] + | WindowName + | Layout + | Workspaces [WsOpt] + deriving (Read, Show) + +infixr 0 :$ +infixr 5 :+ + +data Modifier = Hide + | Color String String + | Short Int + | Wrap String String + deriving (Read, Show) + +data WsOpt = Modifier :% WsType + | WSep Component + deriving (Read, Show) +infixr 0 :% + +data WsType = Current | Empty | Visible + deriving (Read, Show, Eq) + +data EwmhConf = C { root :: Window + , display :: Display } + +data EwmhState = S { currentDesktop :: CLong + , activeWindow :: Window + , desktopNames :: [String] + , layout :: String + , clients :: Map Window Client } + deriving Show + +data Client = Cl { windowName :: String + , desktops :: Set CLong } + deriving Show + +getAtom :: String -> M Atom +getAtom s = do + d <- asks display + liftIO $ internAtom d s False + +windowProperty32 :: String -> Window -> M (Maybe [CLong]) +windowProperty32 s w = do + C {display} <- ask + a <- getAtom s + liftIO $ getWindowProperty32 display a w + +windowProperty8 :: String -> Window -> M (Maybe [CChar]) +windowProperty8 s w = do + C {display} <- ask + a <- getAtom s + liftIO $ getWindowProperty8 display a w + +initialState :: EwmhState +initialState = S 0 0 [] [] Map.empty + +initialClient :: Client +initialClient = Cl "" Set.empty + +handlers, clientHandlers :: [(String, Updater)] +handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop) + , ("_NET_DESKTOP_NAMES", updateDesktopNames ) + , ("_NET_ACTIVE_WINDOW", updateActiveWindow) + , ("_NET_CLIENT_LIST", updateClientList) + ] ++ clientHandlers + +clientHandlers = [ ("_NET_WM_NAME", updateName) + , ("_NET_WM_DESKTOP", updateDesktop) ] + +newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a) + deriving (Monad, Functor, Applicative, MonadIO, MonadReader EwmhConf, MonadState EwmhState) + +execM :: M a -> IO a +execM (M m) = do + d <- openDisplay "" + r <- rootWindow d (defaultScreen d) + let conf = C r d + evalStateT (runReaderT m (C r d)) initialState + +type Updater = Window -> M () + +updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater +updateCurrentDesktop _ = do + C {root} <- ask + mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root + case mwp of + Just [x] -> modify (\s -> s { currentDesktop = x }) + _ -> return () + +updateActiveWindow _ = do + C {root} <- ask + mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root + case mwp of + Just [x] -> modify (\s -> s { activeWindow = fromIntegral x }) + _ -> return () + +updateDesktopNames _ = do + C {root} <- ask + mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root + case mwp of + Just xs -> modify (\s -> s { desktopNames = parse xs }) + _ -> return () + where + dropNull ('\0':xs) = xs + dropNull xs = xs + + split [] = [] + split xs = case span (/= '\0') xs of + (x, ys) -> x : split (dropNull ys) + parse = split . decodeCChar + +updateClientList _ = do + C {root} <- ask + mwp <- windowProperty32 "_NET_CLIENT_LIST" root + case mwp of + Just xs -> do + cl <- gets clients + let cl' = Map.fromList $ map ((, initialClient) . fromIntegral) xs + dels = Map.difference cl cl' + new = Map.difference cl' cl + modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'}) + 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 + listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask + update w = mapM_ (($ w) . snd) clientHandlers + +modifyClient :: Window -> (Client -> Client) -> M () +modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s }) + where + f' Nothing = Just $ f initialClient + f' (Just x) = Just $ f x + +updateName w = do + mwp <- windowProperty8 "_NET_WM_NAME" w + case mwp of + Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs }) + _ -> return () + +updateDesktop w = do + mwp <- windowProperty32 "_NET_WM_DESKTOP" w + case mwp of + Just x -> modifyClient w (\c -> c { desktops = Set.fromList x }) + _ -> return () + +decodeCChar :: [CChar] -> String +#ifdef UTF8 +#undef UTF8 +decodeCChar = UTF8.decode . map fromIntegral +#define UTF8 +#else +decodeCChar = map (toEnum . fromIntegral) +#endif diff --git a/src/Xmobar/Plugins/Kbd.hsc b/src/Xmobar/Plugins/Kbd.hsc new file mode 100644 index 0000000..763150b --- /dev/null +++ b/src/Xmobar/Plugins/Kbd.hsc @@ -0,0 +1,404 @@ +{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Kbd +-- Copyright : (c) Martin Perner +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Martin Perner <martin@perner.cc> +-- Stability : unstable +-- Portability : unportable +-- +-- A keyboard layout indicator for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Kbd where + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Xmobar.Plugins +import Control.Monad (forever) +import Xmobar.XUtil (nextEvent') +import Data.List (isPrefixOf, findIndex) +import Data.Maybe (fromJust) + +#include <X11/XKBlib.h> +#include <X11/extensions/XKB.h> +#include <X11/extensions/XKBstr.h> + +-- +-- Definition for XkbStaceRec and getKbdLayout taken from +-- XMonad.Layout.XKBLayout +-- +data XkbStateRec = XkbStateRec { + group :: CUChar, + locked_group :: CUChar, + base_group :: CUShort, + latched_group :: CUShort, + mods :: CUChar, + base_mods :: CUChar, + latched_mods :: CUChar, + locked_mods :: CUChar, + compat_state :: CUChar, + grab_mods :: CUChar, + compat_grab_mods :: CUChar, + lookup_mods :: CUChar, + compat_lookup_mods :: CUChar, + ptr_buttons :: CUShort +} + +instance Storable XkbStateRec where + sizeOf _ = (#size XkbStateRec) + alignment _ = alignment (undefined :: CUShort) + poke _ _ = undefined + peek ptr = do + r_group <- (#peek XkbStateRec, group) ptr + r_locked_group <- (#peek XkbStateRec, locked_group) ptr + r_base_group <- (#peek XkbStateRec, base_group) ptr + r_latched_group <- (#peek XkbStateRec, latched_group) ptr + r_mods <- (#peek XkbStateRec, mods) ptr + r_base_mods <- (#peek XkbStateRec, base_mods) ptr + r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr + r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr + r_compat_state <- (#peek XkbStateRec, compat_state) ptr + r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr + r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr + r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr + r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr + r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr + return XkbStateRec { + group = r_group, + locked_group = r_locked_group, + base_group = r_base_group, + latched_group = r_latched_group, + mods = r_mods, + base_mods = r_base_mods, + latched_mods = r_latched_mods, + locked_mods = r_locked_mods, + compat_state = r_compat_state, + grab_mods = r_grab_mods, + compat_grab_mods = r_compat_grab_mods, + lookup_mods = r_lookup_mods, + compat_lookup_mods = r_compat_lookup_mods, + ptr_buttons = r_ptr_buttons + } + +foreign import ccall unsafe "X11/XKBlib.h XkbGetState" + xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt + + +getKbdLayout :: Display -> IO Int +getKbdLayout d = alloca $ \stRecPtr -> do + xkbGetState d 0x100 stRecPtr + st <- peek stRecPtr + return $ fromIntegral (group st) + +-- +-- +-- + +data XkbKeyNameRec = XkbKeyNameRec { + name :: Ptr CChar -- array +} + +-- +-- the t_ before alias is just because of name collisions +-- +data XkbKeyAliasRec = XkbKeyAliasRec { + real :: Ptr CChar, -- array + t_alias :: Ptr CChar -- array +} + +-- +-- the t_ before geometry is just because of name collisions +-- +data XkbNamesRec = XkbNamesRec { + keycodes :: Atom, + t_geometry :: Atom, + symbols :: Atom, + types :: Atom, + compat :: Atom, + vmods :: Ptr Atom, + indicators :: Ptr Atom, -- array + groups :: Ptr Atom, -- array + keys :: Ptr XkbKeyNameRec, + key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec, + radio_groups :: Ptr Atom, + phys_symbols :: Atom, + num_keys :: CUChar, + num_key_aliases :: CUChar, + num_rg :: CUShort +} + +-- +-- the t_ before map, indicators and compat are just because of name collisions +-- +data XkbDescRec = XkbDescRec { + t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care + flags :: CUShort, + device_spec :: CUShort, + min_key_code :: KeyCode, + max_key_code :: KeyCode, + ctrls :: Ptr CChar, -- XkbControlsPtr ; dont' care + server :: Ptr CChar, -- XkbServerMapPtr ; dont' care + t_map :: Ptr CChar, --XkbClientMapPtr ; dont' care + t_indicators :: Ptr CChar, -- XkbIndicatorPtr ; dont' care + names :: Ptr XkbNamesRec, -- array + t_compat :: Ptr CChar, -- XkbCompatMap ; dont' care + geom :: Ptr CChar -- XkbGeometryPtr ; dont' care + +} + +instance Storable XkbKeyNameRec where + sizeOf _ = (#size XkbKeyNameRec) + alignment _ = alignment (undefined :: CUShort) + poke _ _ = undefined + peek ptr = do + r_name <- (#peek XkbKeyNameRec, name) ptr + + return XkbKeyNameRec { + name = r_name + } + +instance Storable XkbKeyAliasRec where + sizeOf _ = (#size XkbKeyAliasRec) + alignment _ = alignment (undefined :: CUShort) + poke _ _ = undefined + peek ptr = do + r_real <- (#peek XkbKeyAliasRec, real) ptr + r_alias <- (#peek XkbKeyAliasRec, alias) ptr + + return XkbKeyAliasRec { + real = r_real, + t_alias = r_alias + } + +instance Storable XkbNamesRec where + sizeOf _ = (#size XkbNamesRec) + alignment _ = alignment (undefined :: CUShort) + poke _ _ = undefined + peek ptr = do + r_keycodes <- (#peek XkbNamesRec, keycodes) ptr + r_geometry <- (#peek XkbNamesRec, geometry) ptr + r_symbols <- (#peek XkbNamesRec, symbols ) ptr + r_types <- (#peek XkbNamesRec, types ) ptr + r_compat <- (#peek XkbNamesRec, compat ) ptr + r_vmods <- (#peek XkbNamesRec, vmods ) ptr + r_indicators <- (#peek XkbNamesRec, indicators ) ptr + r_groups <- (#peek XkbNamesRec, groups ) ptr + r_keys <- (#peek XkbNamesRec, keys ) ptr + r_key_aliases <- (#peek XkbNamesRec, key_aliases ) ptr + r_radio_groups <- (#peek XkbNamesRec, radio_groups ) ptr + r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr + r_num_keys <- (#peek XkbNamesRec,num_keys ) ptr + r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases ) ptr + r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr + + return XkbNamesRec { + keycodes = r_keycodes, + t_geometry = r_geometry, + symbols = r_symbols, + types = r_types, + compat = r_compat, + vmods = r_vmods, + indicators = r_indicators, + groups = r_groups, + keys = r_keys, + key_aliases = r_key_aliases, + radio_groups = r_radio_groups, + phys_symbols = r_phys_symbols, + num_keys = r_num_keys, + num_key_aliases = r_num_key_aliases, + num_rg = r_num_rg + } + +instance Storable XkbDescRec where + sizeOf _ = (#size XkbDescRec) + alignment _ = alignment (undefined :: CUShort) + poke _ _ = undefined + peek ptr = do + r_dpy <- (#peek XkbDescRec, dpy) ptr + r_flags <- (#peek XkbDescRec, flags) ptr + r_device_spec <- (#peek XkbDescRec, device_spec) ptr + r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr + r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr + r_ctrls <- (#peek XkbDescRec, ctrls) ptr + r_server <- (#peek XkbDescRec, server) ptr + r_map <- (#peek XkbDescRec, map) ptr + r_indicators <- (#peek XkbDescRec, indicators) ptr + r_names <- (#peek XkbDescRec, names) ptr + r_compat <- (#peek XkbDescRec, compat) ptr + r_geom <- (#peek XkbDescRec, geom) ptr + + return XkbDescRec { + t_dpy = r_dpy, + flags = r_flags, + device_spec = r_device_spec, + min_key_code = r_min_key_code, + max_key_code = r_max_key_code, + ctrls = r_ctrls, + server = r_server, + t_map = r_map, + t_indicators = r_indicators, + names = r_names, + t_compat = r_compat, + geom = r_geom + } + +-- +-- C bindings +-- + +foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard" + xkbAllocKeyboard :: IO (Ptr XkbDescRec) + +foreign import ccall unsafe "X11/XKBlib.h XkbGetNames" + xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec) -> IO Status + +foreign import ccall unsafe "X11/XKBlib.h XGetAtomName" + xGetAtomName :: Display -> Atom -> IO CString + +foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames" + xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () + +foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard" + xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () + +foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails" + xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt + +foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents" + xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt + + +xkbUseCoreKbd :: CUInt +xkbUseCoreKbd = #const XkbUseCoreKbd + +xkbStateNotify :: CUInt +xkbStateNotify = #const XkbStateNotify + +xkbIndicatorStateNotify :: CUInt +xkbIndicatorStateNotify = #const XkbIndicatorStateNotify + +xkbMapNotify :: CUInt +xkbMapNotify = #const XkbMapNotify + +xkbMapNotifyMask :: CUInt +xkbMapNotifyMask = #const XkbMapNotifyMask + +xkbNewKeyboardNotifyMask :: CUInt +xkbNewKeyboardNotifyMask = #const XkbNewKeyboardNotifyMask + +xkbAllStateComponentsMask :: CULong +xkbAllStateComponentsMask = #const XkbAllStateComponentsMask + +xkbGroupStateMask :: CULong +xkbGroupStateMask = #const XkbGroupStateMask + +xkbSymbolsNameMask :: CUInt +xkbSymbolsNameMask = #const XkbSymbolsNameMask + +xkbGroupNamesMask :: CUInt +xkbGroupNamesMask = #const XkbGroupNamesMask + +type KbdOpts = [(String, String)] + +-- gets the layout string +getLayoutStr :: Display -> IO String +getLayoutStr dpy = do + kbdDescPtr <- xkbAllocKeyboard + status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr + str <- getLayoutStr' status dpy kbdDescPtr + xkbFreeNames kbdDescPtr xkbGroupNamesMask 1 + xkbFreeKeyboard kbdDescPtr 0 1 + return str + +getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String +getLayoutStr' st dpy kbdDescPtr = + if st == 0 then -- Success + do + kbdDesc <- peek kbdDescPtr + nameArray <- peek (names kbdDesc) + atom <- xGetAtomName dpy (symbols nameArray) + str <- peekCString atom + return str + else -- Behaviour on error + do + return "Error while requesting layout!" + + +-- 'Bad' prefixes of layouts +noLaySymbols :: [String] +noLaySymbols = ["group", "inet", "ctr", "pc", "ctrl"] + + +-- splits the layout string into the actual layouts +splitLayout :: String -> [String] +splitLayout s = splitLayout' noLaySymbols $ split s '+' + +splitLayout' :: [String] -> [String] -> [String] +-- end of recursion, remove empty strings +splitLayout' [] s = map (takeWhile (\x -> x /= ':')) $ filter (\x -> length x > 0) s +-- remove current string if it has a 'bad' prefix +splitLayout' bad s = splitLayout' (tail bad) [x | x <- s, not $ isPrefixOf (head bad) x] + +-- split String at each Char +split :: String -> Char -> [String] +split [] _ = [""] +split (c:cs) delim + | c == delim = "" : rest + | otherwise = (c : head rest) : tail rest + where + rest = split cs delim + +-- replaces input string if on search list (exact match) with corresponding +-- element on replacement list. +-- +-- if not found, return string unchanged +searchReplaceLayout :: KbdOpts -> String -> String +searchReplaceLayout opts s = let c = findIndex (\x -> fst x == s) opts in + case c of + Nothing -> s + x -> let i = (fromJust x) in + snd $ opts!!i + +-- returns the active layout +getKbdLay :: Display -> KbdOpts -> IO String +getKbdLay dpy opts = do + lay <- getLayoutStr dpy + curLay <- getKbdLayout dpy + return $ searchReplaceLayout opts $ (splitLayout lay)!!(curLay) + + + +data Kbd = Kbd [(String, String)] + deriving (Read, Show) + +instance Exec Kbd where + alias (Kbd _) = "kbd" + start (Kbd opts) cb = do + + dpy <- openDisplay "" + + -- initial set of layout + cb =<< getKbdLay dpy opts + + -- enable listing for + -- group changes + _ <- xkbSelectEventDetails dpy xkbUseCoreKbd xkbStateNotify xkbAllStateComponentsMask xkbGroupStateMask + -- layout/geometry changes + _ <- xkbSelectEvents dpy xkbUseCoreKbd xkbNewKeyboardNotifyMask xkbNewKeyboardNotifyMask + + allocaXEvent $ \e -> forever $ do + nextEvent' dpy e + _ <- getEvent e + cb =<< getKbdLay dpy opts + + closeDisplay dpy + return () + +-- vim:ft=haskell:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20: diff --git a/src/Xmobar/Plugins/Locks.hs b/src/Xmobar/Plugins/Locks.hs new file mode 100644 index 0000000..9a971e5 --- /dev/null +++ b/src/Xmobar/Plugins/Locks.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Locks +-- Copyright : (c) Patrick Chilton +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Patrick Chilton <chpatrick@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin that displays the status of the lock keys. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Locks where + +import Graphics.X11 +import Data.List +import Data.Bits +import Control.Monad +import Graphics.X11.Xlib.Extras +import Xmobar.Plugins +import Xmobar.Plugins.Kbd +import Xmobar.XUtil (nextEvent') + +data Locks = Locks + deriving (Read, Show) + +locks :: [ ( KeySym, String )] +locks = [ ( xK_Caps_Lock, "CAPS" ) + , ( xK_Num_Lock, "NUM" ) + , ( 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" + start Locks cb = do + d <- openDisplay "" + root <- rootWindow d (defaultScreen d) + _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m + + allocaXEvent $ \ep -> forever $ do + cb =<< run' d root + nextEvent' d ep + getEvent ep + + closeDisplay d + return () + where + m = xkbAllStateComponentsMask diff --git a/src/Xmobar/Plugins/MBox.hs b/src/Xmobar/Plugins/MBox.hs new file mode 100644 index 0000000..2281629 --- /dev/null +++ b/src/Xmobar/Plugins/MBox.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.MBox +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for checking mail in mbox files. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.MBox (MBox(..)) where + +import Prelude +import Xmobar.Plugins +#ifdef INOTIFY +import Xmobar.Plugins.Utils (changeLoop, expandHome) + +import Control.Monad (when) +import Control.Concurrent.STM +import Control.Exception (SomeException (..), handle, evaluate) + +import System.Console.GetOpt +import System.Directory (doesFileExist) +import System.FilePath ((</>)) +import System.INotify (Event(..), EventVariety(..), initINotify, addWatch) + +import qualified Data.ByteString.Lazy.Char8 as B + +#if MIN_VERSION_hinotify(0,3,10) +import qualified Data.ByteString.Char8 as BS (ByteString, pack) +pack :: String -> BS.ByteString +pack = BS.pack +#else +pack :: String -> String +pack = id +#endif + +data Options = Options + { oAll :: Bool + , oUniq :: Bool + , oDir :: FilePath + , oPrefix :: String + , oSuffix :: String + } + +defaults :: Options +defaults = Options { + oAll = False, oUniq = False, oDir = "", oPrefix = "", oSuffix = "" + } + +options :: [OptDescr (Options -> Options)] +options = + [ Option "a" ["all"] (NoArg (\o -> o { oAll = True })) "" + , Option "u" [] (NoArg (\o -> o { oUniq = True })) "" + , Option "d" ["dir"] (ReqArg (\x o -> o { oDir = x }) "") "" + , Option "p" ["prefix"] (ReqArg (\x o -> o { oPrefix = x }) "") "" + , Option "s" ["suffix"] (ReqArg (\x o -> o { oSuffix = x }) "") "" + ] + +parseOptions :: [String] -> IO Options +parseOptions args = + case getOpt Permute options args of + (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 + deriving (Read, Show) + +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 + suffix = oSuffix opts + uniq = oUniq opts + names = map (\(t, _, _) -> t) boxes + colors = map (\(_, _, c) -> c) boxes + extractPath (_, f, _) = expandHome $ oDir opts </> f + events = [CloseWrite] + + i <- initINotify + vs <- mapM (\b -> do + f <- extractPath b + exists <- doesFileExist f + n <- if exists then countMails f else return (-1) + v <- newTVarIO (f, n) + when exists $ + addWatch i events (pack f) (handleNotification v) >> return () + return v) + boxes + + changeLoop (mapM (fmap snd . readTVar) vs) $ \ns -> + let s = unwords [ showC uniq m n c | (m, n, c) <- zip3 names ns colors + , showAll || n > 0 ] + in cb (if null s then "" else prefix ++ s ++ suffix) + +showC :: Bool -> String -> Int -> String -> String +showC u m n c = + if c == "" then msg else "<fc=" ++ c ++ ">" ++ msg ++ "</fc>" + where msg = m ++ if not u || n > 1 then show n else "" + +countMails :: FilePath -> IO Int +countMails f = + handle (\(SomeException _) -> evaluate 0) + (do txt <- B.readFile f + evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt) + where from = B.pack "From " + +handleNotification :: TVar (FilePath, Int) -> Event -> IO () +handleNotification v _ = do + (p, _) <- atomically $ readTVar v + n <- countMails p + atomically $ writeTVar v (p, n) +#endif diff --git a/src/Xmobar/Plugins/Mail.hs b/src/Xmobar/Plugins/Mail.hs new file mode 100644 index 0000000..c41b5b3 --- /dev/null +++ b/src/Xmobar/Plugins/Mail.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Mail +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <sjanssen@cse.unl.edu> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for checking mail. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Mail where + +import Xmobar.Plugins +#ifdef INOTIFY +import Xmobar.Plugins.Utils (expandHome, changeLoop) + +import Control.Monad +import Control.Concurrent.STM + +import System.Directory +import System.FilePath +import System.INotify + +import Data.List (isPrefixOf) +import Data.Set (Set) +import qualified Data.Set as S + +#if MIN_VERSION_hinotify(0,3,10) +import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack) +unpack :: BS.ByteString -> String +unpack = BS.unpack +pack :: String -> BS.ByteString +pack = BS.pack +#else +unpack :: String -> String +unpack = id +pack :: String -> String +pack = id +#endif +#else +import System.IO +#endif + + +-- | A list of mail box names and paths to maildirs. +data Mail = Mail [(String, FilePath)] String + deriving (Read, Show) + +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 + + let ts = map fst ms + rs = map ((</> "new") . snd) ms + ev = [Move, MoveIn, MoveOut, Create, Delete] + + ds <- mapM expandHome rs + i <- initINotify + zipWithM_ (\d v -> addWatch i ev d (handle v)) (map pack ds) vs + + forM_ (zip ds vs) $ \(d, v) -> do + s <- fmap (S.fromList . filter (not . isPrefixOf ".")) + $ getDirectoryContents d + 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 ] + +handle :: TVar (Set String) -> Event -> IO () +handle v e = atomically $ modifyTVar v $ case e of + Created {} -> create + MovedIn {} -> create + Deleted {} -> delete + MovedOut {} -> delete + _ -> id + where + delete = S.delete ((unpack . filePath) e) + create = S.insert ((unpack . filePath) e) +#endif diff --git a/src/Xmobar/Plugins/MarqueePipeReader.hs b/src/Xmobar/Plugins/MarqueePipeReader.hs new file mode 100644 index 0000000..ad6f27f --- /dev/null +++ b/src/Xmobar/Plugins/MarqueePipeReader.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.MarqueePipeReader where + +import System.IO (openFile, IOMode(ReadWriteMode), Handle) +import Xmobar.Environment +import Xmobar.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) +import Control.Applicative ((<$>)) + +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 + (def, pipe) <- split ':' <$> expandEnv 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/Xmobar/Plugins/Monitors.hs b/src/Xmobar/Plugins/Monitors.hs new file mode 100644 index 0000000..64d38f0 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Plugins.Monitors +-- Copyright : (c) 2010, 2011, 2012, 2013, 2017, 2018 Jose Antonio Ortega Ruiz +-- (c) 2007-10 Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- The system monitor plugin for Xmobar. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors where + +import Xmobar.Plugins + +import Xmobar.Plugins.Monitors.Common (runM, runMD) +#ifdef WEATHER +import Xmobar.Plugins.Monitors.Weather +#endif +import Xmobar.Plugins.Monitors.Net +import Xmobar.Plugins.Monitors.Mem +import Xmobar.Plugins.Monitors.Swap +import Xmobar.Plugins.Monitors.Cpu +import Xmobar.Plugins.Monitors.MultiCpu +import Xmobar.Plugins.Monitors.Batt +import Xmobar.Plugins.Monitors.Bright +import Xmobar.Plugins.Monitors.Thermal +import Xmobar.Plugins.Monitors.ThermalZone +import Xmobar.Plugins.Monitors.CpuFreq +import Xmobar.Plugins.Monitors.CoreTemp +import Xmobar.Plugins.Monitors.Disk +import Xmobar.Plugins.Monitors.Top +import Xmobar.Plugins.Monitors.Uptime +import Xmobar.Plugins.Monitors.CatInt +#ifdef UVMETER +import Xmobar.Plugins.Monitors.UVMeter +#endif +#ifdef IWLIB +import Xmobar.Plugins.Monitors.Wireless +#endif +#ifdef LIBMPD +import Xmobar.Plugins.Monitors.MPD +import Xmobar.Plugins.Monitors.Common (runMBD) +#endif +#ifdef ALSA +import Xmobar.Plugins.Monitors.Volume +import Xmobar.Plugins.Monitors.Alsa +#endif +#ifdef MPRIS +import Xmobar.Plugins.Monitors.Mpris +#endif + +data Monitors = Network Interface Args Rate + | DynNetwork Args Rate + | BatteryP Args Args Rate + | BatteryN Args Args Rate Alias + | Battery Args Rate + | DiskU DiskSpec Args Rate + | DiskIO DiskSpec Args Rate + | Thermal Zone Args Rate + | ThermalZone ZoneNo Args Rate + | Memory Args Rate + | Swap Args Rate + | Cpu Args Rate + | MultiCpu Args Rate + | Brightness Args Rate + | CpuFreq Args Rate + | CoreTemp Args Rate + | TopProc Args Rate + | TopMem Args Rate + | Uptime Args Rate + | CatInt Int FilePath Args Rate +#ifdef WEATHER + | Weather Station Args Rate +#endif +#ifdef UVMETER + | UVMeter Station Args Rate +#endif +#ifdef IWLIB + | Wireless Interface Args Rate +#endif +#ifdef LIBMPD + | MPD Args Rate + | AutoMPD Args +#endif +#ifdef ALSA + | Volume String String Args Rate + | Alsa String String Args +#endif +#ifdef MPRIS + | Mpris1 String Args Rate + | Mpris2 String Args Rate +#endif + deriving (Show,Read,Eq) + +type Args = [String] +type Program = String +type Alias = String +type Station = String +type Zone = String +type ZoneNo = Int +type Interface = String +type Rate = Int +type DiskSpec = [(String, String)] + +instance Exec Monitors where +#ifdef WEATHER + alias (Weather s _ _) = s +#endif + alias (Network i _ _) = i + alias (DynNetwork _ _) = "dynnetwork" + alias (Thermal z _ _) = z + alias (ThermalZone z _ _) = "thermal" ++ show z + alias (Memory _ _) = "memory" + alias (Swap _ _) = "swap" + alias (Cpu _ _) = "cpu" + alias (MultiCpu _ _) = "multicpu" + alias (Battery _ _) = "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 (Uptime _ _) = "uptime" + alias (CatInt n _ _ _) = "cat" ++ show n +#ifdef UVMETER + alias (UVMeter s _ _) = "uv " ++ s +#endif +#ifdef IWLIB + alias (Wireless i _ _) = i ++ "wi" +#endif +#ifdef LIBMPD + alias (MPD _ _) = "mpd" + alias (AutoMPD _) = "autompd" +#endif +#ifdef ALSA + alias (Volume m c _ _) = m ++ ":" ++ c + alias (Alsa m c _) = "alsa:" ++ m ++ ":" ++ c +#endif +#ifdef MPRIS + alias (Mpris1 _ _ _) = "mpris1" + alias (Mpris2 _ _ _) = "mpris2" +#endif + start (Network i a r) = startNet i a r + start (DynNetwork a r) = startDynNet a r + start (Cpu a r) = startCpu a r + start (MultiCpu a r) = startMultiCpu a r + start (TopProc a r) = startTop a r + start (TopMem a r) = runM a topMemConfig runTopMem r +#ifdef WEATHER + start (Weather s a r) = runMD (a ++ [s]) weatherConfig runWeather r weatherReady +#endif + start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r + start (ThermalZone z a r) = + runM (a ++ [show z]) thermalZoneConfig runThermalZone r + start (Memory a r) = runM a memConfig runMem r + start (Swap a r) = runM a swapConfig runSwap r + start (Battery a r) = runM a battConfig runBatt r + start (BatteryP s a r) = runM a battConfig (runBatt' s) r + start (BatteryN s a r _) = runM a battConfig (runBatt' s) r + start (Brightness a r) = runM a brightConfig runBright r + start (CpuFreq a r) = runM a cpuFreqConfig runCpuFreq r + start (CoreTemp a r) = runM a coreTempConfig runCoreTemp r + 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 UVMETER + start (UVMeter s a r) = runM (a ++ [s]) uvConfig runUVMeter r +#endif +#ifdef IWLIB + start (Wireless i a r) = runM a wirelessConfig (runWireless i) r +#endif +#ifdef LIBMPD + 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 + start (Alsa m c a) = startAlsaPlugin m c a +#endif +#ifdef MPRIS + start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r + start (Mpris2 s a r) = runM a mprisConfig (runMPRIS2 s) r +#endif diff --git a/src/Xmobar/Plugins/Monitors/Batt.hs b/src/Xmobar/Plugins/Monitors/Batt.hs new file mode 100644 index 0000000..80f4275 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Batt.hs @@ -0,0 +1,247 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Batt +-- Copyright : (c) 2010, 2011, 2012, 2013, 2015, 2016, 2018 Jose A Ortega +-- (c) 2010 Andrea Rossato, Petr Rockai +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A battery monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where + +import Control.Exception (SomeException, handle) +import Xmobar.Plugins.Monitors.Common +import System.FilePath ((</>)) +import System.IO (IOMode(ReadMode), hGetLine, withFile) +import System.Posix.Files (fileExist) +import System.Console.GetOpt +import Data.List (sort, sortBy, group) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Text.Read (readMaybe) + +data BattOpts = BattOpts + { onString :: String + , offString :: String + , idleString :: String + , posColor :: Maybe String + , lowWColor :: Maybe String + , mediumWColor :: Maybe String + , highWColor :: Maybe String + , lowThreshold :: Float + , highThreshold :: Float + , onlineFile :: FilePath + , scale :: Float + , onIconPattern :: Maybe IconPattern + , offIconPattern :: Maybe IconPattern + , idleIconPattern :: Maybe IconPattern + } + +defaultOpts :: BattOpts +defaultOpts = BattOpts + { onString = "On" + , offString = "Off" + , idleString = "On" + , posColor = Nothing + , lowWColor = Nothing + , mediumWColor = Nothing + , highWColor = Nothing + , lowThreshold = 10 + , highThreshold = 12 + , onlineFile = "AC/online" + , scale = 1e6 + , onIconPattern = Nothing + , offIconPattern = Nothing + , idleIconPattern = Nothing + } + +options :: [OptDescr (BattOpts -> BattOpts)] +options = + [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" + , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") "" + , Option "i" ["idle"] (ReqArg (\x o -> o { idleString = x }) "") "" + , Option "p" ["positive"] (ReqArg (\x o -> o { posColor = Just x }) "") "" + , Option "l" ["low"] (ReqArg (\x o -> o { lowWColor = Just x }) "") "" + , Option "m" ["medium"] (ReqArg (\x o -> o { mediumWColor = Just x }) "") "" + , Option "h" ["high"] (ReqArg (\x o -> o { highWColor = Just x }) "") "" + , Option "L" ["lowt"] (ReqArg (\x o -> o { lowThreshold = read x }) "") "" + , 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 +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +data Status = Charging | Discharging | Full | Idle | Unknown deriving (Read, Eq) + +data Result = Result Float Float Float Status | NA + +sysDir :: FilePath +sysDir = "/sys/class/power_supply" + +battConfig :: IO MConfig +battConfig = mkMConfig + "Batt: <watts>, <left>% / <timeleft>" -- template + ["leftbar", "leftvbar", "left", "acstatus", "timeleft", "watts", "leftipat"] -- replacements + +data Files = Files + { fFull :: String + , fNow :: String + , fVoltage :: String + , fCurrent :: String + , fStatus :: String + , isCurrent :: Bool + } | NoFiles deriving Eq + +data Battery = Battery + { full :: !Float + , now :: !Float + , power :: !Float + , status :: !String + } + +safeFileExist :: String -> String -> IO Bool +safeFileExist d f = handle noErrors $ fileExist (d </> f) + where noErrors = const (return False) :: SomeException -> IO Bool + +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_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 is_power + (_, True) -> files "energy" cf sf is_power + _ -> NoFiles + where prefix = sysDir </> bat + exists = safeFileExist prefix + files ch cf sf ip = Files { fFull = prefix </> ch ++ "_full" ++ sf + , fNow = prefix </> ch ++ "_now" + , fCurrent = prefix </> cf + , fVoltage = prefix </> "voltage_now" + , fStatus = prefix </> "status" + , isCurrent = not ip} + +haveAc :: FilePath -> IO Bool +haveAc f = + handle onError $ withFile (sysDir </> f) ReadMode (fmap (== "1") . hGetLine) + where onError = const (return False) :: SomeException -> IO Bool + +readBattery :: Float -> Files -> IO Battery +readBattery _ NoFiles = return $ Battery 0 0 0 "Unknown" +readBattery sc files = + do a <- grab $ fFull files + b <- grab $ fNow files + d <- grab $ fCurrent files + s <- grabs $ fStatus files + let sc' = if isCurrent files then sc / 10 else sc + a' = max a b -- sometimes the reported max charge is lower than + return $ Battery (3600 * a' / sc') -- wattseconds + (3600 * b / sc') -- wattseconds + (d / sc') -- watts + s -- string: Discharging/Charging/Full + where grab f = handle onError $ withFile f ReadMode (fmap read . hGetLine) + onError = const (return (-1)) :: SomeException -> IO Float + grabs f = handle onError' $ withFile f ReadMode hGetLine + onError' = const (return "Unknown") :: SomeException -> IO String + +-- sortOn is only available starting at ghc 7.10 +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +mostCommonDef :: Eq a => a -> [a] -> a +mostCommonDef x xs = head $ last $ [x] : sortOn length (group xs) + +readBatteries :: BattOpts -> [Files] -> IO Result +readBatteries opts bfs = + do let bfs' = filter (/= NoFiles) bfs + bats <- mapM (readBattery (scale opts)) (take 3 bfs') + ac <- haveAc (onlineFile opts) + let sign = if ac then 1 else -1 + ft = sum (map full bats) + left = if ft > 0 then sum (map now bats) / ft else 0 + watts = sign * sum (map power bats) + time = if watts == 0 then 0 else max 0 (sum $ map time' bats) + mwatts = if watts == 0 then 1 else sign * watts + time' b = (if ac then full b - now b else now b) / mwatts + statuses :: [Status] + statuses = map (fromMaybe Unknown . readMaybe) + (sort (map status bats)) + acst = mostCommonDef Unknown $ filter (Unknown/=) statuses + racst | acst /= Unknown = acst + | time == 0 = Idle + | ac = Charging + | otherwise = Discharging + return $ if isNaN left then NA else Result left watts time racst + +runBatt :: [String] -> Monitor String +runBatt = runBatt' ["BAT", "BAT0", "BAT1", "BAT2"] + +runBatt' :: [String] -> [String] -> Monitor String +runBatt' bfs args = do + opts <- io $ parseOpts args + c <- io $ readBatteries opts =<< mapM batteryFiles bfs + suffix <- getConfigValue useSuffix + d <- getConfigValue decDigits + nas <- getConfigValue naString + case c of + Result x w t s -> + do l <- fmtPercent x + ws <- fmtWatts w opts suffix d + si <- getIconPattern opts s x + parseTemplate (l ++ [fmtStatus opts s nas, 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' + 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 _ Unknown na = na + fmtStatus opts Full _ = 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 st x = do + let x' = minimum [1, x] + case st of + Unknown -> showIconPattern (offIconPattern opts) x' + Idle -> showIconPattern (idleIconPattern opts) x' + Full -> showIconPattern (idleIconPattern opts) x' + Charging -> showIconPattern (onIconPattern opts) x' + Discharging -> showIconPattern (offIconPattern opts) x' diff --git a/src/Xmobar/Plugins/Monitors/Bright.hs b/src/Xmobar/Plugins/Monitors/Bright.hs new file mode 100644 index 0000000..fe72219 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Bright.hs @@ -0,0 +1,99 @@ +----------------------------------------------------------------------------- +---- | +---- Module : Plugins.Monitors.Birght +---- Copyright : (c) Martin Perner +---- License : BSD-style (see LICENSE) +---- +---- Maintainer : Martin Perner <martin@perner.cc> +---- Stability : unstable +---- Portability : unportable +---- +---- A screen brightness monitor for Xmobar +---- +------------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Bright (brightConfig, runBright) where + +import Control.Applicative ((<$>)) +import Control.Exception (SomeException, handle) +import qualified Data.ByteString.Lazy.Char8 as B +import System.FilePath ((</>)) +import System.Posix.Files (fileExist) +import System.Console.GetOpt + +import Xmobar.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 +parseOpts :: [String] -> IO BrightOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +sysDir :: FilePath +sysDir = "/sys/class/backlight/" + +brightConfig :: IO MConfig +brightConfig = mkMConfig "<percent>" -- template + ["vbar", "percent", "bar", "ipat"] -- replacements + +data Files = Files { fCurr :: String + , fMax :: String + } + | NoFiles + +brightFiles :: BrightOpts -> IO Files +brightFiles opts = do + 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 +runBright args = do + opts <- io $ parseOpts args + f <- io $ brightFiles opts + c <- io $ readBright f + case f of + NoFiles -> return "hurz" + _ -> 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 (read . B.unpack <$> B.readFile f) + handler = const (return 0) :: SomeException -> IO Float + diff --git a/src/Xmobar/Plugins/Monitors/CatInt.hs b/src/Xmobar/Plugins/Monitors/CatInt.hs new file mode 100644 index 0000000..781eded --- /dev/null +++ b/src/Xmobar/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 Xmobar.Plugins.Monitors.CatInt where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.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/Xmobar/Plugins/Monitors/Common.hs b/src/Xmobar/Plugins/Monitors/Common.hs new file mode 100644 index 0000000..272690b --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Common.hs @@ -0,0 +1,544 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Common +-- Copyright : (c) 2010, 2011, 2013, 2016, 2017, 2018 Jose Antonio Ortega Ruiz +-- (c) 2007-2010 Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Utilities used by xmobar's monitors +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Common ( + -- * Monitors + -- $monitor + Monitor + , MConfig (..) + , Opts (..) + , setConfigValue + , getConfigValue + , mkMConfig + , runM + , runMD + , runMB + , runMBD + , io + -- * Parsers + -- $parsers + , runP + , skipRestOfLine + , getNumbers + , getNumbersAsString + , getAllBut + , getAfterString + , skipTillString + , parseTemplate + , parseTemplate' + -- ** String Manipulation + -- $strings + , IconPattern + , parseIconPattern + , padString + , showWithPadding + , showWithColors + , showWithColors' + , showPercentWithColors + , showPercentsWithColors + , showPercentBar + , showVerticalBar + , showIconPattern + , showLogBar + , showLogVBar + , showLogIconPattern + , showWithUnits + , takeDigits + , showDigits + , floatToPercent + , parseFloat + , parseInt + , stringParser + ) 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 +import Control.Exception (SomeException,handle) + +import Xmobar.Plugins +-- $monitor + +type Monitor a = ReaderT MConfig IO a + +data MConfig = + MC { normalColor :: IORef (Maybe String) + , low :: IORef Int + , lowColor :: IORef (Maybe String) + , high :: IORef Int + , highColor :: IORef (Maybe String) + , template :: IORef String + , export :: IORef [String] + , ppad :: IORef Int + , decDigits :: IORef Int + , minWidth :: IORef Int + , maxWidth :: IORef Int + , maxWidthEllipsis :: IORef String + , padChars :: IORef String + , padRight :: IORef Bool + , barBack :: IORef String + , barFore :: IORef String + , barWidth :: IORef Int + , useSuffix :: IORef Bool + , naString :: IORef String + , maxTotalWidth :: IORef Int + , maxTotalWidthEllipsis :: IORef String + } + +-- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' +type Selector a = MConfig -> IORef a + +sel :: Selector a -> Monitor a +sel s = + do hs <- ask + liftIO $ readIORef (s hs) + +mods :: Selector a -> (a -> a) -> Monitor () +mods s m = + do v <- ask + io $ modifyIORef (s v) m + +setConfigValue :: a -> Selector a -> Monitor () +setConfigValue v s = + mods s (const v) + +getConfigValue :: Selector a -> Monitor a +getConfigValue = sel + +mkMConfig :: String + -> [String] + -> IO MConfig +mkMConfig tmpl exprts = + do lc <- newIORef Nothing + l <- newIORef 33 + nc <- newIORef Nothing + h <- newIORef 66 + hc <- newIORef Nothing + t <- newIORef tmpl + e <- newIORef exprts + p <- newIORef 0 + d <- newIORef 0 + mn <- newIORef 0 + mx <- newIORef 0 + mel <- newIORef "" + pc <- newIORef " " + pr <- newIORef False + bb <- newIORef ":" + bf <- newIORef "#" + bw <- newIORef 10 + up <- newIORef False + na <- newIORef "N/A" + mt <- newIORef 0 + mtel <- newIORef "" + return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel + +data Opts = HighColor String + | NormalColor String + | LowColor String + | Low String + | High String + | Template String + | PercentPad String + | DecDigits String + | MinWidth String + | MaxWidth String + | Width String + | WidthEllipsis String + | PadChars String + | PadAlign String + | BarBack String + | BarFore String + | BarWidth String + | UseSuffix String + | NAString String + | MaxTotalWidth String + | MaxTotalWidthEllipsis 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 "e" ["maxwidthellipsis"] (ReqArg WidthEllipsis "Maximum width ellipsis") "Ellipsis to be added to the field when it has reached its max 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" + , Option "T" ["maxtwidth"] (ReqArg MaxTotalWidth "Maximum total width") "Maximum total width" + , Option "E" ["maxtwidthellipsis"] (ReqArg MaxTotalWidthEllipsis "Maximum total width ellipsis") "Ellipsis to be added to the total text when it has reached its max width." + ] + +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 + ready <- detect n + if ready + then action n + else return "<Waiting...>" + (_, _, errs) -> return (concat errs) + +doConfigOptions :: [Opts] -> Monitor () +doConfigOptions [] = io $ return () +doConfigOptions (o:oo) = + do let next = doConfigOptions oo + nz s = let x = read s in max 0 x + bool = (`elem` ["True", "true", "Yes", "yes", "On", "on"]) + (case o of + High h -> setConfigValue (read h) high + Low l -> setConfigValue (read l) low + HighColor c -> setConfigValue (Just c) highColor + NormalColor c -> setConfigValue (Just c) normalColor + LowColor c -> setConfigValue (Just c) lowColor + Template t -> setConfigValue t template + PercentPad p -> setConfigValue (nz p) ppad + DecDigits d -> setConfigValue (nz d) decDigits + MinWidth w -> setConfigValue (nz w) minWidth + MaxWidth w -> setConfigValue (nz w) maxWidth + Width w -> setConfigValue (nz w) minWidth >> + setConfigValue (nz w) maxWidth + WidthEllipsis e -> setConfigValue e maxWidthEllipsis + PadChars s -> setConfigValue s padChars + PadAlign a -> setConfigValue ("r" `isPrefixOf` a) padRight + BarBack s -> setConfigValue s barBack + BarFore s -> setConfigValue s barFore + BarWidth w -> setConfigValue (nz w) barWidth + UseSuffix u -> setConfigValue (bool u) useSuffix + NAString s -> setConfigValue s naString + MaxTotalWidth w -> setConfigValue (nz w) maxTotalWidth + MaxTotalWidthEllipsis e -> setConfigValue e maxTotalWidthEllipsis) >> next + +runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int + -> (String -> IO ()) -> IO () +runM args conf action r = runMB args conf action (tenthSeconds r) + +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 +showException = ("error: "++) . show . flip asTypeOf undefined + +io :: IO a -> Monitor a +io = liftIO + +-- $parsers + +runP :: Parser [a] -> String -> IO [a] +runP p i = + case parse p "" i of + Left _ -> return [] + Right x -> return x + +getAllBut :: String -> Parser String +getAllBut s = + manyTill (noneOf s) (char $ head s) + +getNumbers :: Parser Float +getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n + +getNumbersAsString :: Parser String +getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n + +skipRestOfLine :: Parser Char +skipRestOfLine = + do many $ noneOf "\n\r" + newline + +getAfterString :: String -> Parser String +getAfterString s = + do { try $ manyTill skipRestOfLine $ string s + ; manyTill anyChar newline + } <|> return "" + +skipTillString :: String -> Parser String +skipTillString s = + manyTill skipRestOfLine $ string s + +-- | Parses the output template string +templateStringParser :: Parser (String,String,String) +templateStringParser = + do { s <- nonPlaceHolder + ; com <- templateCommandParser + ; ss <- nonPlaceHolder + ; return (s, com, ss) + } + where + nonPlaceHolder = fmap concat . many $ + many1 (noneOf "<") <|> colorSpec <|> iconSpec + +-- | Recognizes color specification and returns it unchanged +colorSpec :: Parser String +colorSpec = try (string "</fc>") <|> try ( + do string "<fc=" + s <- many1 (alphaNum <|> char ',' <|> char '#') + char '>' + return $ "<fc=" ++ s ++ ">") + +-- | Recognizes icon specification and returns it unchanged +iconSpec :: Parser String +iconSpec = try (do string "<icon=" + i <- manyTill (noneOf ">") (try (string "/>")) + return $ "<icon=" ++ i ++ "/>") + +-- | Parses the command part of the template string +templateCommandParser :: Parser String +templateCommandParser = + do { char '<' + ; com <- many $ noneOf ">" + ; char '>' + ; return com + } + +-- | Combines the template parsers +templateParser :: Parser [(String,String,String)] +templateParser = many templateStringParser --"%") + +trimTo :: Int -> String -> String -> (Int, String) +trimTo n p "" = (n, p) +trimTo n p ('<':cs) = trimTo n p' s + where p' = p ++ "<" ++ takeWhile (/= '>') cs ++ ">" + s = drop 1 (dropWhile (/= '>') cs) +trimTo 0 p s = trimTo 0 p (dropWhile (/= '<') s) +trimTo n p s = let p' = takeWhile (/= '<') s + s' = dropWhile (/= '<') s + in + if length p' <= n + then trimTo (n - length p') (p ++ p') s' + else trimTo 0 (p ++ take n p') s' + +-- | Takes a list of strings that represent the values of the exported +-- keys. The strings are joined with the exported keys to form a map +-- to be combined with 'combine' to the parsed template. Returns the +-- final output of the monitor, trimmed to MaxTotalWidth if that +-- configuration value is positive. +parseTemplate :: [String] -> Monitor String +parseTemplate l = + do t <- getConfigValue template + e <- getConfigValue export + w <- getConfigValue maxTotalWidth + ell <- getConfigValue maxTotalWidthEllipsis + let m = Map.fromList . zip e $ l + s <- parseTemplate' t m + let (n, s') = if w > 0 && length s > w + then trimTo (w - length ell) "" s + else (1, s) + return $ if n > 0 then s' else s' ++ ell + +-- | Parses the template given to it with a map of export values and combines +-- them +parseTemplate' :: String -> Map.Map String String -> Monitor String +parseTemplate' t m = + do s <- io $ runP templateParser t + combine m s + +-- | Given a finite "Map" and a parsed template t produces the +-- | resulting output string as the output of the monitor. +combine :: Map.Map String String -> [(String, String, String)] -> Monitor String +combine _ [] = return [] +combine m ((s,ts,ss):xs) = + do next <- combine m xs + 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 -> intercalate (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 +takeDigits d n = + fromIntegral (round (n * fact) :: Int) / fact + where fact = 10 ^ d + +showDigits :: (RealFloat a) => Int -> a -> String +showDigits d n = showFFloat (Just d) n "" + +showWithUnits :: Int -> Int -> Float -> String +showWithUnits d n x + | x < 0 = '-' : showWithUnits d n (-x) + | n > 3 || x < 10^(d + 1) = show (round x :: Int) ++ units n + | x <= 1024 = showDigits d (x/1024) ++ units (n+1) + | otherwise = showWithUnits d (n+1) (x/1024) + where units = (!!) ["B", "K", "M", "G", "T"] + +padString :: Int -> Int -> String -> Bool -> String -> String -> String +padString mnw mxw pad pr ellipsis s = + let len = length s + rmin = if mnw <= 0 then 1 else mnw + rmax = if mxw <= 0 then max len rmin else mxw + (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin) + rlen = min (max rmn len) rmx + in if rlen < len then + take rlen s ++ ellipsis + else let ps = take (rlen - len) (cycle pad) + in if pr then s ++ ps else ps ++ s + +parseFloat :: String -> Float +parseFloat s = case readFloat s of + (v, _):_ -> v + _ -> 0 + +parseInt :: String -> Int +parseInt s = case readDec s of + (v, _):_ -> v + _ -> 0 + +floatToPercent :: Float -> Monitor String +floatToPercent n = + do pad <- getConfigValue ppad + pc <- getConfigValue padChars + pr <- getConfigValue padRight + up <- getConfigValue useSuffix + let p = showDigits 0 (n * 100) + ps = if up then "%" else "" + return $ padString pad pad pc pr "" p ++ ps + +stringParser :: Pos -> B.ByteString -> String +stringParser (x,y) = + B.unpack . li x . B.words . li y . B.lines + where li i l | length l > i = l !! i + | otherwise = B.empty + +setColor :: String -> Selector (Maybe String) -> Monitor String +setColor str s = + do a <- getConfigValue s + case a of + Nothing -> return str + Just c -> return $ + "<fc=" ++ c ++ ">" ++ str ++ "</fc>" + +showWithPadding :: String -> Monitor String +showWithPadding s = + do mn <- getConfigValue minWidth + mx <- getConfigValue maxWidth + p <- getConfigValue padChars + pr <- getConfigValue padRight + ellipsis <- getConfigValue maxWidthEllipsis + return $ padString mn mx p pr ellipsis s + +colorizeString :: (Num a, Ord a) => a -> String -> Monitor String +colorizeString x s = do + h <- getConfigValue high + l <- getConfigValue low + let col = setColor s + [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low + head $ [col highColor | x > hh ] ++ + [col normalColor | x > ll ] ++ + [col lowColor | True] + +showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String +showWithColors f x = showWithPadding (f x) >>= colorizeString x + +showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String +showWithColors' str = showWithColors (const str) + +showPercentsWithColors :: [Float] -> Monitor [String] +showPercentsWithColors fs = + do fstrs <- mapM floatToPercent fs + zipWithM (showWithColors . const) fstrs (map (*100) fs) + +showPercentWithColors :: Float -> Monitor String +showPercentWithColors f = fmap head $ showPercentsWithColors [f] + +showPercentBar :: Float -> Float -> Monitor String +showPercentBar v x = do + bb <- getConfigValue barBack + bf <- getConfigValue barFore + bw <- getConfigValue barWidth + let len = min bw $ round (fromIntegral bw * x) + 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) + +logScaling :: Float -> Float -> Monitor Float +logScaling f v = do + h <- fromIntegral `fmap` getConfigValue high + l <- fromIntegral `fmap` getConfigValue low + bw <- fromIntegral `fmap` getConfigValue barWidth + let [ll, hh] = sort [l, h] + scaled x | x == 0.0 = 0 + | x <= ll = 1 / bw + | otherwise = f + logBase 2 (x / hh) / bw + return $ scaled v + +showLogBar :: Float -> Float -> Monitor String +showLogBar f v = logScaling f v >>= showPercentBar v + +showLogVBar :: Float -> Float -> Monitor String +showLogVBar f v = logScaling f v >>= showVerticalBar v + +showLogIconPattern :: Maybe IconPattern -> Float -> Float -> Monitor String +showLogIconPattern str f v = logScaling f v >>= showIconPattern str diff --git a/src/Xmobar/Plugins/Monitors/CoreCommon.hs b/src/Xmobar/Plugins/Monitors/CoreCommon.hs new file mode 100644 index 0000000..a84198e --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/CoreCommon.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CoreCommon +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- The common part for cpu core monitors (e.g. cpufreq, coretemp) +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.CoreCommon where + +#if __GLASGOW_HASKELL__ < 800 +import Control.Applicative +#endif + +import Data.Char hiding (Space) +import Data.Function +import Data.List +import Data.Maybe +import Xmobar.Plugins.Monitors.Common +import System.Directory + +checkedDataRetrieval :: (Ord a, Num a) + => String -> [[String]] -> Maybe (String, String -> Int) + -> (Double -> a) -> (a -> String) -> Monitor String +checkedDataRetrieval msg paths lbl trans fmt = + fmap (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 =<< findFilesAndLabel path lbl) + if null pairs + then return Nothing + else Just <$> ( parseTemplate + =<< mapM (showWithColors fmt . trans . read) pairs + ) + +-- | Represents the different types of path components +data Comp = Fix String + | Var [String] + deriving Show + +-- | Used to represent parts of file names separated by slashes and spaces +data CompOrSep = Slash + | Space + | Comp String + deriving (Eq, Show) + +-- | Function to turn a list of of strings into a list of path components +pathComponents :: [String] -> [Comp] +pathComponents = joinComps . drop 2 . intercalate [Space] . map splitParts + where + splitParts p | (l, _:r) <- break (== '/') p = Comp l : Slash : splitParts r + | otherwise = [Comp p] + + joinComps = uncurry joinComps' . partition isComp + + isComp (Comp _) = True + isComp _ = False + + fromComp (Comp s) = s + fromComp _ = error "fromComp applied to value other than (Comp _)" + + joinComps' cs [] = [Fix $ fromComp $ head cs] -- cs should have only one element here, + -- but this keeps the pattern matching + -- exhaustive + joinComps' cs (p:ps) = let (ss, ps') = span (== p) ps + ct = if null ps' || (p == Space) then length ss + 1 + else length ss + (ls, rs) = splitAt (ct+1) cs + c = case p of + Space -> Var $ map fromComp ls + Slash -> Fix $ intercalate "/" $ map fromComp ls + _ -> error "Should not happen" + in if null ps' then [c] + else c:joinComps' rs (drop ct ps) + +-- | Function to find all files matching the given path and possible label file. +-- The path must be absolute (start with a leading slash). +findFilesAndLabel :: [String] -> Maybe (String, String -> Int) + -> Monitor [(String, Either Int (String, String -> Int))] +findFilesAndLabel path lbl = catMaybes + <$> ( mapM addLabel . zip [0..] . sort + =<< recFindFiles (pathComponents path) "/" + ) + where + addLabel (i, f) = maybe (return $ Just (f, Left i)) + (uncurry (justIfExists f)) + lbl + + justIfExists f s t = let f' = take (length f - length s) f ++ s + in ifthen (Just (f, Right (f', t))) Nothing <$> io (doesFileExist f') + + recFindFiles [] d = ifthen [d] [] + <$> io (if null d then return False else doesFileExist d) + recFindFiles ps d = ifthen (recFindFiles' ps d) (return []) + =<< io (if null d then return True else doesDirectoryExist d) + + recFindFiles' [] _ = error "Should not happen" + recFindFiles' (Fix p:ps) d = recFindFiles ps (d ++ "/" ++ p) + recFindFiles' (Var p:ps) d = concat + <$> ((mapM (recFindFiles ps + . (\f -> d ++ "/" ++ f)) + . filter (matchesVar p)) + =<< io (getDirectoryContents d) + ) + + matchesVar [] _ = False + matchesVar [v] f = v == f + matchesVar (v:vs) f = let f' = drop (length v) f + f'' = dropWhile isDigit f' + in and [ v `isPrefixOf` f + , not (null f') + , isDigit (head f') + , matchesVar vs f'' + ] + +-- | Function to read the contents of the given file(s) +readFiles :: (String, Either Int (String, String -> Int)) + -> Monitor (Int, String) +readFiles (fval, flbl) = (,) <$> either return (\(f, ex) -> fmap ex + $ io $ readFile f) flbl + <*> io (readFile fval) + +-- | Function that captures if-then-else +ifthen :: a -> a -> Bool -> a +ifthen thn els cnd = if cnd then thn else els diff --git a/src/Xmobar/Plugins/Monitors/CoreTemp.hs b/src/Xmobar/Plugins/Monitors/CoreTemp.hs new file mode 100644 index 0000000..48fe428 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/CoreTemp.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CoreTemp +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- A core temperature monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.CoreTemp where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.Plugins.Monitors.CoreCommon + + +import Data.Char (isDigit) + +-- | +-- Core temperature default configuration. Default template contains only one +-- core temperature, user should specify custom template in order to get more +-- core frequencies. +coreTempConfig :: IO MConfig +coreTempConfig = mkMConfig + "Temp: <core0>C" -- template + (map ((++) "core" . show) [0 :: Int ..]) -- available + -- replacements + +-- | +-- Function retrieves monitor string holding the core temperature +-- (or temperatures) +runCoreTemp :: [String] -> Monitor String +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/Xmobar/Plugins/Monitors/Cpu.hs b/src/Xmobar/Plugins/Monitors/Cpu.hs new file mode 100644 index 0000000..6befe7d --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Cpu.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Cpu +-- Copyright : (c) 2011, 2017 Jose Antonio Ortega Ruiz +-- (c) 2007-2010 Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A cpu monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Cpu (startCpu) where + +import Xmobar.Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.Console.GetOpt + +newtype 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","vbar","ipat","total","user","nice","system","idle","iowait"] + +type CpuDataRef = IORef [Int] + +cpuData :: IO [Int] +cpuData = cpuParser `fmap` B.readFile "/proc/stat" + +cpuParser :: B.ByteString -> [Int] +cpuParser = map (read . B.unpack) . tail . B.words . head . B.lines + +parseCpu :: CpuDataRef -> IO [Float] +parseCpu cref = + do a <- readIORef cref + b <- cpuData + writeIORef cref b + let dif = zipWith (-) b a + tot = fromIntegral $ sum dif + percent = map ((/ tot) . fromIntegral) dif + return percent + +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:v:d:ps) + +runCpu :: CpuDataRef -> [String] -> Monitor String +runCpu cref argv = + do c <- io (parseCpu cref) + opts <- io $ parseOpts argv + l <- formatCpu opts c + parseTemplate l + +startCpu :: [String] -> Int -> (String -> IO ()) -> IO () +startCpu a r cb = do + cref <- newIORef [] + _ <- parseCpu cref + runM a cpuConfig (runCpu cref) r cb diff --git a/src/Xmobar/Plugins/Monitors/CpuFreq.hs b/src/Xmobar/Plugins/Monitors/CpuFreq.hs new file mode 100644 index 0000000..1afedfa --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/CpuFreq.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CpuFreq +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- A cpu frequency monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.CpuFreq where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.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. +cpuFreqConfig :: IO MConfig +cpuFreqConfig = + mkMConfig "Freq: <cpu0>" (map ((++) "cpu" . show) [0 :: Int ..]) + + +-- | +-- Function retrieves monitor string holding the cpu frequency (or +-- frequencies) +runCpuFreq :: [String] -> Monitor String +runCpuFreq _ = do + suffix <- getConfigValue useSuffix + ddigits <- getConfigValue decDigits + let path = ["/sys/devices/system/cpu/cpu", "/cpufreq/scaling_cur_freq"] + divisor = 1e6 :: Double + fmt x | x < 1 = if suffix then mhzFmt x ++ "MHz" + else ghzFmt x + | otherwise = ghzFmt x ++ if suffix then "GHz" else "" + mhzFmt x = show (round (x * 1000) :: Integer) + ghzFmt = showDigits ddigits + failureMessage <- getConfigValue naString + checkedDataRetrieval failureMessage [path] Nothing (/divisor) fmt diff --git a/src/Xmobar/Plugins/Monitors/Disk.hs b/src/Xmobar/Plugins/Monitors/Disk.hs new file mode 100644 index 0000000..aedad75 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Disk.hs @@ -0,0 +1,241 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Disk +-- Copyright : (c) 2010, 2011, 2012, 2014 Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Disk usage and throughput monitors for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.StatFS + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) + +import Control.Exception (SomeException, handle) +import Control.Monad (zipWithM) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (isPrefixOf, find) +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" + ,"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", "freevbar", "freeipat" + , "usedbar", "usedvbar", "usedipat" + ] + +type DevName = String +type Path = String +type DevDataRef = IORef [(DevName, [Float])] + +mountedDevices :: [String] -> IO [(DevName, Path)] +mountedDevices req = do + s <- B.readFile "/etc/mtab" + 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 . catMaybes + firstTwo (a:b:_) = (B.unpack a, B.unpack b) + firstTwo _ = ("", "") + isDev (d, _) = "/dev/" `isPrefixOf` d + isReq (d, p) = p `elem` req || drop 5 d `elem` req + undev (d, f) = (drop 5 d, f) + +diskDevices :: [String] -> IO [(DevName, Path)] +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)} + devs = map (third . B.words) . B.lines + parse = map undev . filter isReq + 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) + +mountedOrDiskDevices :: [String] -> IO [(DevName, Path)] +mountedOrDiskDevices req = do + mnt <- mountedDevices req + case mnt of + [] -> diskDevices req + other -> return other + +diskData :: IO [(DevName, [Float])] +diskData = do + s <- B.readFile "/proc/diskstats" + let extract ws = (head ws, map read (tail ws)) + return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s) + +mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])] +mountedData dref devs = do + dt <- readIORef dref + dt' <- diskData + writeIORef dref dt' + return $ map (parseDev (zipWith diff dt' dt)) devs + where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys) + +parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float]) +parseDev dat dev = + case find ((==dev) . fst) dat of + Nothing -> (dev, [0, 0, 0]) + Just (_, xs) -> + let rSp = speed (xs !! 2) (xs !! 3) + wSp = speed (xs !! 6) (xs !! 7) + sp = speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7) + speed x t = if t == 0 then 0 else 500 * x / t + dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0] + in (dev, dat') + +speedToStr :: Float -> String +speedToStr = showWithUnits 2 1 + +sizeToStr :: Integer -> String +sizeToStr = showWithUnits 3 0 . fromIntegral + +findTempl :: DevName -> Path -> [(String, String)] -> String +findTempl dev path disks = + case find devOrPath disks of + Just (_, t) -> t + Nothing -> "" + where devOrPath (d, _) = d == dev || d == path + +devTemplates :: [(String, String)] + -> [(DevName, Path)] + -> [(DevName, [Float])] + -> [(String, [Float])] +devTemplates disks mounted dat = + map (\(d, p) -> (findTempl d p disks, findData d)) mounted + where findData dev = case find ((==dev) . fst) dat of + Nothing -> [0, 0, 0] + Just (_, xs) -> xs + +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 ++ vb ++ ipat + +runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String +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' opts) $ devTemplates disks dev dat + return $ unwords strs + +startDiskIO :: [(String, String)] -> + [String] -> Int -> (String -> IO ()) -> IO () +startDiskIO disks args rate cb = do + dev <- mountedOrDiskDevices (map fst disks) + dref <- newIORef (map (\d -> (fst d, repeat 0)) dev) + _ <- mountedData dref (map fst dev) + runM args diskIOConfig (runDiskIO dref disks) rate cb + +fsStats :: String -> IO [Integer] +fsStats path = do + stats <- getFileSystemStats path + case stats of + Nothing -> return [0, 0, 0] + Just f -> let tot = fsStatByteCount f + free = fsStatBytesAvailable f + used = fsStatBytesUsed f + in return [tot, free, used] + +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 [free, diff] + freep = if total > 0 then free * 100 `div` total else 0 + fr = fromIntegral freep / 100 + 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) + 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 argv = do + devs <- io $ mountedDevices (map fst disks) + opts <- io $ parseDiskUOpts argv + strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs + return $ unwords strs diff --git a/src/Xmobar/Plugins/Monitors/MPD.hs b/src/Xmobar/Plugins/Monitors/MPD.hs new file mode 100644 index 0000000..9525254 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/MPD.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.MPD +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- MPD status and song +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait, mpdReady ) where + +import Data.List +import Data.Maybe (fromMaybe) +import Xmobar.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", "vbar", "ipat", "state", "statei", "volume", "length" + , "lapsed", "remaining", "plength", "ppos", "flags", "file" + , "name", "artist", "composer", "performer" + , "album", "title", "track", "genre", "date" + ] + +data MOpts = MOpts + { mPlaying :: String + , mStopped :: String + , mPaused :: String + , mLapsedIconPattern :: Maybe IconPattern + } + +defaultOpts :: MOpts +defaultOpts = MOpts + { mPlaying = ">>" + , mStopped = "><" + , mPaused = "||" + , mLapsedIconPattern = Nothing + } + +options :: [OptDescr (MOpts -> MOpts)] +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 + status <- io $ M.withMPD M.status + song <- io $ M.withMPD M.currentSong + s <- parseMPD status song opts + parseTemplate s + +mpdWait :: IO () +mpdWait = do + status <- M.withMPD $ M.idle [M.PlayerS, M.MixerS, M.OptionsS] + 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 = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +parseMPD :: M.Response M.Status -> M.Response (Maybe M.Song) -> MOpts + -> Monitor [String] +parseMPD (Left e) _ _ = return $ show e:replicate 19 "" +parseMPD (Right st) song opts = do + songData <- parseSong song + bar <- showPercentBar (100 * b) b + 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 $ 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 = + case s of + M.Playing -> mPlaying 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 "" +parseSong (Right (Just s)) = + let str sel = maybe "" (intercalate ", " . map M.toString) (M.sgGetTag sel s) + sels = [ M.Name, M.Artist, M.Composer, M.Performer + , M.Album, M.Title, M.Track, M.Genre, M.Date ] + fields = M.toString (M.sgFilePath s) : map str sels + in mapM showWithPadding fields + +showTime :: Integer -> String +showTime t = int2str minutes ++ ":" ++ int2str seconds + where minutes = t `div` 60 + seconds = t `mod` 60 + +int2str :: (Show a, Num a, Ord a) => a -> String +int2str x = if x < 10 then '0':sx else sx where sx = show x diff --git a/src/Xmobar/Plugins/Monitors/Mem.hs b/src/Xmobar/Plugins/Monitors/Mem.hs new file mode 100644 index 0000000..d69921b --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Mem.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Mem +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A memory monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where + +import Xmobar.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", "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" + +parseMEM :: IO [Float] +parseMEM = + do file <- fileMEM + 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 + availableratio = available / total + return [usedratio, freeratio, availableratio, total, free, buffer, cache, available, used] + +totalMem :: IO Float +totalMem = fmap ((*1024) . (!!1)) parseMEM + +usedMem :: IO Float +usedMem = fmap ((*1024) . (!!6)) parseMEM + +formatMem :: MemOpts -> [Float] -> Monitor [String] +formatMem opts (r:fr:ar:xs) = + do let f = showDigits 0 + 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 argv = + do m <- io parseMEM + opts <- io $ parseOpts argv + l <- formatMem opts m + parseTemplate l diff --git a/src/Xmobar/Plugins/Monitors/Mpris.hs b/src/Xmobar/Plugins/Monitors/Mpris.hs new file mode 100644 index 0000000..3556649 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Mpris.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} + +---------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Mpris +-- Copyright : (c) Artem Tarasov +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Artem Tarasov <lomereiter@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- MPRIS song info +-- +---------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Mpris ( mprisConfig, runMPRIS1, runMPRIS2 ) where + +-- TODO: listen to signals + +import Xmobar.Plugins.Monitors.Common + +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) + +import Control.Exception (try) + +class MprisVersion a where + getMethodCall :: a -> String -> MethodCall + getMetadataReply :: a -> DC.Client -> String -> IO [Variant] + getMetadataReply mv c p = fmap methodReturnBody (DC.call_ c $ getMethodCall mv p) + fieldsList :: a -> [String] + +data MprisVersion1 = MprisVersion1 +instance MprisVersion MprisVersion1 where + getMethodCall MprisVersion1 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + } + where + busName = busName_ $ "org.mpris." ++ p + objectPath = objectPath_ "/Player" + interfaceName = interfaceName_ "org.freedesktop.MediaPlayer" + memberName = memberName_ "GetMetadata" + + fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title" + , "tracknumber" ] + +data MprisVersion2 = MprisVersion2 +instance MprisVersion MprisVersion2 where + getMethodCall MprisVersion2 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + , methodCallBody = arguments + } + where + 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"] + + fieldsList MprisVersion2 = [ "xesam:album", "xesam:artist", "mpris:artUrl" + , "mpris:length", "xesam:title", + "xesam:trackNumber", "xesam:composer", + "xesam:genre" + ] + +mprisConfig :: IO MConfig +mprisConfig = mkMConfig "<artist> - <title>" + [ "album", "artist", "arturl", "length" + , "title", "tracknumber" , "composer", "genre" + ] + +{-# NOINLINE dbusClient #-} +dbusClient :: DC.Client +dbusClient = unsafePerformIO DC.connectSession + +runMPRIS :: (MprisVersion a) => a -> String -> [String] -> Monitor String +runMPRIS version playerName _ = do + metadata <- io $ getMetadata version dbusClient playerName + if [] == metadata then + getConfigValue naString + else mapM showWithPadding (makeList version metadata) >>= parseTemplate + +runMPRIS1 :: String -> [String] -> Monitor String +runMPRIS1 = runMPRIS MprisVersion1 + +runMPRIS2 :: String -> [String] -> Monitor String +runMPRIS2 = runMPRIS MprisVersion2 + +--------------------------------------------------------------------------- + +fromVar :: (IsVariant a) => Variant -> a +fromVar = fromJust . fromVariant + +unpackMetadata :: [Variant] -> [(String, Variant)] +unpackMetadata [] = [] +unpackMetadata xs = + (map (fromVar *** fromVar) . unpack . head) xs where + unpack v = case variantType v of + TypeDictionary _ _ -> dictionaryItems $ fromVar v + TypeVariant -> unpack $ fromVar v + TypeStructure _ -> + let x = structureItems (fromVar v) in + if null x then [] else unpack (head x) + _ -> [] + +getMetadata :: (MprisVersion a) => a -> DC.Client -> String -> IO [(String, Variant)] +getMetadata version client player = do + reply <- try (getMetadataReply version client player) :: + IO (Either DC.ClientError [Variant]) + return $ case reply of + Right metadata -> unpackMetadata metadata; + Left _ -> [] + +makeList :: (MprisVersion a) => a -> [(String, Variant)] -> [String] +makeList version md = map getStr (fieldsList version) where + formatTime n = (if hh == 0 then printf "%02d:%02d" + else printf "%d:%02d:%02d" hh) mm ss + where hh = (n `div` 60) `div` 60 + mm = (n `div` 60) `mod` 60 + ss = n `mod` 60 + getStr str = case lookup str md of + Nothing -> "" + Just v -> case variantType v of + TypeString -> fromVar v + TypeInt32 -> let num = fromVar v in + case str of + "mtime" -> formatTime (num `div` 1000) + "tracknumber" -> printf "%02d" num + "mpris:length" -> formatTime (num `div` 1000000) + "xesam:trackNumber" -> printf "%02d" num + _ -> (show::Int32 -> String) num + TypeInt64 -> let num = fromVar v in + case str of + "mpris:length" -> formatTime (num `div` 1000000) + _ -> (show::Int64 -> String) num + TypeArray TypeString -> + let x = arrayItems (fromVar v) in + if null x then "" else fromVar (head x) + _ -> "" diff --git a/src/Xmobar/Plugins/Monitors/MultiCpu.hs b/src/Xmobar/Plugins/Monitors/MultiCpu.hs new file mode 100644 index 0000000..3db3b5f --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/MultiCpu.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.MultiCpu +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A multi-cpu monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.MultiCpu (startMultiCpu) where + +import Xmobar.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 + , fallbackIconPattern :: Maybe IconPattern + } + +defaultOpts :: MultiCpuOpts +defaultOpts = MultiCpuOpts + { loadIconPatterns = [] + , loadIconPattern = Nothing + , fallbackIconPattern = 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 }) "") "" + , Option "" ["fallback-icon-pattern"] (ReqArg (\x o -> + o { fallbackIconPattern = Just $ parseIconPattern x }) "") "" + ] + +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 <- variables] ++ + [ k ++ n | n <- "" : map show [0 :: Int ..] + , k <- variables] + +type CpuDataRef = IORef [[Int]] + +cpuData :: IO [[Int]] +cpuData = parse `fmap` B.readFile "/proc/stat" + where parse = map parseList . cpuLists + cpuLists = takeWhile isCpu . map B.words . B.lines + isCpu (w:_) = "cpu" `isPrefixOf` B.unpack w + isCpu _ = False + parseList = map (parseInt . B.unpack) . tail + +parseCpuData :: CpuDataRef -> IO [[Float]] +parseCpuData cref = + do as <- readIORef cref + bs <- cpuData + writeIORef cref bs + let p0 = zipWith percent bs as + return p0 + +percent :: [Int] -> [Int] -> [Float] +percent b a = if tot > 0 then map (/ tot) $ take 4 dif else [0, 0, 0, 0] + where dif = map fromIntegral $ zipWith (-) b a + tot = sum dif + +formatMultiCpus :: MultiCpuOpts -> [[Float]] -> Monitor [String] +formatMultiCpus _ [] = return [] +formatMultiCpus opts xs = concat <$> mapM (\(i, x) -> formatCpu opts i x) (zip [0..] 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:h:d:ps) + where tryString + | i == 0 = loadIconPattern opts + | i <= length (loadIconPatterns opts) = Just $ loadIconPatterns opts !! (i - 1) + | otherwise = fallbackIconPattern opts + +splitEvery :: Int -> [a] -> [[a]] +splitEvery n = unfoldr (\x -> if null x then Nothing else Just $ splitAt n x) + +groupData :: [String] -> [[String]] +groupData = transpose . tail . splitEvery vNum + +formatAutoCpus :: [String] -> Monitor [String] +formatAutoCpus [] = return $ replicate vNum "" +formatAutoCpus xs = return $ map unwords (groupData xs) + +runMultiCpu :: CpuDataRef -> [String] -> Monitor String +runMultiCpu cref argv = + do c <- io $ parseCpuData cref + opts <- io $ parseOpts argv + l <- formatMultiCpus opts c + a <- formatAutoCpus l + parseTemplate $ a ++ l + +startMultiCpu :: [String] -> Int -> (String -> IO ()) -> IO () +startMultiCpu a r cb = do + cref <- newIORef [[]] + _ <- parseCpuData cref + runM a multiCpuConfig (runMultiCpu cref) r cb diff --git a/src/Xmobar/Plugins/Monitors/Net.hs b/src/Xmobar/Plugins/Monitors/Net.hs new file mode 100644 index 0000000..81a5f6b --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Net.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Net +-- Copyright : (c) 2011, 2012, 2013, 2014, 2017 Jose Antonio Ortega Ruiz +-- (c) 2007-2010 Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A net device monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Net ( + startNet + , startDynNet + ) where + +import Xmobar.Plugins.Monitors.Common + +import Data.Word (Word64) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) +import Control.Monad (forM, filterM) +import System.Directory (getDirectoryContents, doesFileExist) +import System.FilePath ((</>)) +import System.Console.GetOpt +import System.IO.Error (catchIOError) + +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 num + = NA + | NI String + | ND String num num deriving (Eq,Show,Read) + +type NetDevRawTotal = NetDev Word64 +type NetDevRate = NetDev Float + +type NetDevRef = IORef (NetDevRawTotal, UTCTime) + +-- The more information available, the better. +-- Note that names don't matter. Therefore, if only the names differ, +-- a compare evaluates to EQ while (==) evaluates to False. +instance Ord num => Ord (NetDev num) where + compare NA NA = EQ + compare NA _ = LT + compare _ NA = GT + compare (NI _) (NI _) = EQ + compare (NI _) ND {} = LT + compare ND {} (NI _) = GT + compare (ND _ x1 y1) (ND _ x2 y2) = + if downcmp /= EQ + then downcmp + else y1 `compare` y2 + where downcmp = x1 `compare` x2 + +netConfig :: IO MConfig +netConfig = mkMConfig + "<dev>: <rx>KB|<tx>KB" -- template + ["dev", "rx", "tx", "rxbar", "rxvbar", "rxipat", "txbar", "txvbar", "txipat"] -- available replacements + +operstateDir :: String -> FilePath +operstateDir d = "/sys/class/net" </> d </> "operstate" + +existingDevs :: IO [String] +existingDevs = getDirectoryContents "/sys/class/net" >>= filterM isDev + where isDev d | d `elem` excludes = return False + | otherwise = doesFileExist (operstateDir d) + excludes = [".", "..", "lo"] + +isUp :: String -> IO Bool +isUp d = flip catchIOError (const $ return False) $ do + operstate <- B.readFile (operstateDir d) + return $! (B.unpack . head . B.lines) operstate `elem` ["up", "unknown"] + +readNetDev :: [String] -> IO NetDevRawTotal +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 + +readNetDev _ = return NA + +netParser :: B.ByteString -> IO [NetDevRawTotal] +netParser = mapM (readNetDev . splitDevLine) . readDevLines + where readDevLines = drop 2 . B.lines + splitDevLine = selectCols . wordsBy (`elem` " :") . B.unpack + selectCols cols = map (cols!!) [0,1,9] + wordsBy f s = case dropWhile f s of + [] -> [] + s' -> w : wordsBy f s'' where (w, s'') = break f s' + +findNetDev :: String -> IO NetDevRawTotal +findNetDev dev = do + nds <- B.readFile "/proc/net/dev" >>= netParser + case filter isDev nds of + x:_ -> return x + _ -> return NA + where isDev (ND d _ _) = d == dev + isDev (NI d) = d == dev + isDev NA = False + +formatNet :: Maybe IconPattern -> Float -> Monitor (String, String, String, String) +formatNet mipat d = do + s <- getConfigValue useSuffix + dd <- getConfigValue decDigits + 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 + vb <- showLogVBar 0.9 d + ipat <- showLogIconPattern mipat 0.9 d + x <- showWithColors (str s) d + return (x, b, vb, ipat) + +printNet :: NetOpts -> NetDevRate -> Monitor String +printNet opts nd = + case nd of + ND d r t -> do + (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 -> getConfigValue naString + +parseNet :: NetDevRef -> String -> IO NetDevRate +parseNet nref nd = do + (n0, t0) <- readIORef nref + n1 <- findNetDev nd + t1 <- getCurrentTime + writeIORef nref (n1, t1) + let scx = realToFrac (diffUTCTime t1 t0) + scx' = if scx > 0 then scx else 1 + rate da db = takeDigits 2 $ fromIntegral (db - da) / scx' + diffRate (ND d ra ta) (ND _ rb tb) = ND d (rate ra rb) (rate ta tb) + diffRate (NI d) _ = NI d + diffRate _ (NI d) = NI d + diffRate _ _ = NA + return $ diffRate n0 n1 + +runNet :: NetDevRef -> String -> [String] -> Monitor String +runNet nref i argv = do + dev <- io $ parseNet nref i + opts <- io $ parseOpts argv + printNet opts dev + +parseNets :: [(NetDevRef, String)] -> IO [NetDevRate] +parseNets = mapM $ uncurry parseNet + +runNets :: [(NetDevRef, String)] -> [String] -> Monitor String +runNets refs argv = do + dev <- io $ parseActive refs + opts <- io $ parseOpts argv + printNet opts dev + where parseActive refs' = fmap selectActive (parseNets refs') + selectActive = maximum + +startNet :: String -> [String] -> Int -> (String -> IO ()) -> IO () +startNet i a r cb = do + t0 <- getCurrentTime + nref <- newIORef (NA, t0) + _ <- parseNet nref i + runM a netConfig (runNet nref i) r cb + +startDynNet :: [String] -> Int -> (String -> IO ()) -> IO () +startDynNet a r cb = do + devs <- existingDevs + refs <- forM devs $ \d -> do + t <- getCurrentTime + nref <- newIORef (NA, t) + _ <- 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/Xmobar/Plugins/Monitors/Swap.hs b/src/Xmobar/Plugins/Monitors/Swap.hs new file mode 100644 index 0000000..fcaab84 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Swap.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Swap +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A swap usage monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Swap where + +import Xmobar.Plugins.Monitors.Common + +import qualified Data.ByteString.Lazy.Char8 as B + +swapConfig :: IO MConfig +swapConfig = mkMConfig + "Swap: <usedratio>%" -- template + ["usedratio", "total", "used", "free"] -- available replacements + +fileMEM :: IO B.ByteString +fileMEM = B.readFile "/proc/meminfo" + +parseMEM :: IO [Float] +parseMEM = + do file <- fileMEM + let li i l + | l /= [] = head l !! i + | otherwise = B.empty + fs s l + | 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 + free = get_data "SwapFree:" st + return [(tot - free) / tot, tot, tot - free, free] + +formatSwap :: [Float] -> Monitor [String] +formatSwap (r:xs) = do + d <- getConfigValue decDigits + other <- mapM (showWithColors (showDigits d)) xs + ratio <- showPercentWithColors r + return $ ratio:other +formatSwap _ = return $ replicate 4 "N/A" + +runSwap :: [String] -> Monitor String +runSwap _ = + do m <- io parseMEM + l <- formatSwap m + parseTemplate l diff --git a/src/Xmobar/Plugins/Monitors/Thermal.hs b/src/Xmobar/Plugins/Monitors/Thermal.hs new file mode 100644 index 0000000..320ae17 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Thermal.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Thermal +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- A thermal monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Thermal where + +import qualified Data.ByteString.Lazy.Char8 as B +import Xmobar.Plugins.Monitors.Common +import System.Posix.Files (fileExist) + +-- | Default thermal configuration. +thermalConfig :: IO MConfig +thermalConfig = mkMConfig + "Thm: <temp>C" -- template + ["temp"] -- available replacements + +-- | Retrieves thermal information. Argument is name of thermal directory in +-- \/proc\/acpi\/thermal_zone. Returns the monitor string parsed according to +-- template (either default or user specified). +runThermal :: [String] -> Monitor String +runThermal args = do + let zone = head args + file = "/proc/acpi/thermal_zone/" ++ zone ++ "/temperature" + exists <- io $ fileExist file + if exists + then do number <- io $ fmap ((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/Xmobar/Plugins/Monitors/ThermalZone.hs b/src/Xmobar/Plugins/Monitors/ThermalZone.hs new file mode 100644 index 0000000..bc46b59 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/ThermalZone.hs @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Plugins.Monitors.ThermalZone +-- Copyright : (c) 2011, 2013 Jose Antonio Ortega Ruiz +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : portable +-- Created : Fri Feb 25, 2011 03:18 +-- +-- +-- A thermal zone plugin based on the sysfs linux interface. +-- See http://kernel.org/doc/Documentation/thermal/sysfs-api.txt +-- +------------------------------------------------------------------------------ + +module Xmobar.Plugins.Monitors.ThermalZone (thermalZoneConfig, runThermalZone) where + +import Xmobar.Plugins.Monitors.Common + +import System.Posix.Files (fileExist) +import Control.Exception (IOException, catch) +import qualified Data.ByteString.Char8 as B + +-- | Default thermal configuration. +thermalZoneConfig :: IO MConfig +thermalZoneConfig = mkMConfig "<temp>C" ["temp"] + +-- | Retrieves thermal information. Argument is name of thermal +-- directory in \/sys\/clas\/thermal. Returns the monitor string +-- parsed according to template (either default or user specified). +runThermalZone :: [String] -> Monitor String +runThermalZone args = do + let zone = head args + file = "/sys/class/thermal/thermal_zone" ++ zone ++ "/temp" + handleIOError :: IOException -> IO (Maybe B.ByteString) + handleIOError _ = return Nothing + parse = return . (read :: String -> Int) . B.unpack + exists <- io $ fileExist file + if exists + then do contents <- io $ catch (fmap Just $ B.readFile file) handleIOError + case contents of + Just d -> do + mdegrees <- parse d + temp <- showWithColors show (mdegrees `quot` 1000) + parseTemplate [ temp ] + Nothing -> getConfigValue naString + else getConfigValue naString diff --git a/src/Xmobar/Plugins/Monitors/Top.hs b/src/Xmobar/Plugins/Monitors/Top.hs new file mode 100644 index 0000000..d6df249 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Top.hs @@ -0,0 +1,195 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Top +-- Copyright : (c) 2010, 2011, 2012, 2013, 2014, 2018 Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Process activity and memory consumption monitors +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE BangPatterns #-} + +module Xmobar.Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where + +import Xmobar.Plugins.Monitors.Common + +import Control.Exception (SomeException, handle) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (sortBy, foldl') +import Data.Ord (comparing) +import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) +import System.Directory (getDirectoryContents) +import System.FilePath ((</>)) +import System.IO (IOMode(ReadMode), hGetLine, withFile) +import System.Posix.Unistd (SysVar(ClockTick), getSysVar) + +import Foreign.C.Types + +maxEntries :: Int +maxEntries = 10 + +intStrs :: [String] +intStrs = map show [1..maxEntries] + +topMemConfig :: IO MConfig +topMemConfig = mkMConfig "<both1>" + [ k ++ n | n <- intStrs , k <- ["name", "mem", "both"]] + +topConfig :: IO MConfig +topConfig = mkMConfig "<both1>" + ("no" : [ k ++ n | n <- intStrs + , k <- [ "name", "cpu", "both" + , "mname", "mem", "mboth"]]) + +foreign import ccall "unistd.h getpagesize" + c_getpagesize :: CInt + +pageSize :: Float +pageSize = fromIntegral c_getpagesize / 1024 + +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 (statWords . words) . hGetLine + ign = const (return []) :: SomeException -> IO [String] + +memPages :: [String] -> String +memPages fs = fs!!23 + +ppid :: [String] -> String +ppid fs = fs!!3 + +skip :: [String] -> Bool +skip fs = length fs < 24 || memPages fs == "0" || ppid fs == "0" + +handleProcesses :: ([String] -> a) -> IO [a] +handleProcesses f = + fmap (foldl' (\a p -> if skip p then a else f p : a) []) + (processes >>= mapM getProcessData) + +showInfo :: String -> String -> Float -> Monitor [String] +showInfo nm sms mms = do + mnw <- getConfigValue maxWidth + mxw <- getConfigValue minWidth + let lsms = length sms + nmw = mnw - lsms - 1 + nmx = mxw - lsms - 1 + rnm = if nmw > 0 then padString nmw nmx " " True "" nm else nm + mstr <- showWithColors' sms mms + both <- showWithColors' (rnm ++ " " ++ sms) mms + return [nm, mstr, both] + +processName :: [String] -> String +processName = drop 1 . init . (!!1) + +sortTop :: [(String, Float)] -> [(String, Float)] +sortTop = sortBy (flip (comparing snd)) + +type MemInfo = (String, Float) + +meminfo :: [String] -> MemInfo +meminfo fs = (processName fs, pageSize * parseFloat (fs!!23)) + +meminfos :: IO [MemInfo] +meminfos = handleProcesses meminfo + +showMemInfo :: Float -> MemInfo -> Monitor [String] +showMemInfo scale (nm, rss) = + showInfo nm (showWithUnits 3 1 rss) (100 * rss / sc) + where sc = if scale > 0 then scale else 100 + +showMemInfos :: [MemInfo] -> Monitor [[String]] +showMemInfos ms = mapM (showMemInfo tm) ms + where tm = sum (map snd ms) + +runTopMem :: [String] -> Monitor String +runTopMem _ = do + mis <- io meminfos + pstr <- showMemInfos (sortTop mis) + parseTemplate $ concat pstr + +type Pid = Int +type TimeInfo = (String, Float) +type TimeEntry = (Pid, TimeInfo) +type Times = [TimeEntry] +type TimesRef = IORef (Times, UTCTime) + +timeMemEntry :: [String] -> (TimeEntry, MemInfo) +timeMemEntry fs = ((p, (n, t)), (n, r)) + where p = parseInt (head fs) + n = processName fs + t = parseFloat (fs!!13) + parseFloat (fs!!14) + (_, r) = meminfo fs + +timeMemEntries :: IO [(TimeEntry, MemInfo)] +timeMemEntries = handleProcesses timeMemEntry + +timeMemInfos :: IO (Times, [MemInfo], Int) +timeMemInfos = fmap res timeMemEntries + where res x = (sortBy (comparing fst) $ map fst x, map snd x, length x) + +combine :: Times -> Times -> Times +combine _ [] = [] +combine [] ts = ts +combine l@((p0, (n0, t0)):ls) r@((p1, (n1, t1)):rs) + | p0 == p1 && n0 == n1 = (p0, (n0, t1 - t0)) : combine ls rs + | p0 <= p1 = combine ls r + | otherwise = (p1, (n1, t1)) : combine l rs + +take' :: Int -> [a] -> [a] +take' m l = let !r = tk m l in length l `seq` r + where tk 0 _ = [] + tk _ [] = [] + tk n (x:xs) = let !r = tk (n - 1) xs in x : r + +topProcesses :: TimesRef -> Float -> IO (Int, [TimeInfo], [MemInfo]) +topProcesses tref scale = do + (t0, c0) <- readIORef tref + (t1, mis, len) <- timeMemInfos + c1 <- getCurrentTime + let scx = realToFrac (diffUTCTime c1 c0) * scale + !scx' = if scx > 0 then scx else scale + nts = map (\(_, (nm, t)) -> (nm, min 100 (t / scx'))) (combine t0 t1) + !t1' = take' (length t1) t1 + !nts' = take' maxEntries (sortTop nts) + !mis' = take' maxEntries (sortTop mis) + writeIORef tref (t1', c1) + return (len, nts', mis') + +showTimeInfo :: TimeInfo -> Monitor [String] +showTimeInfo (n, t) = + getConfigValue decDigits >>= \d -> showInfo n (showDigits d t) t + +showTimeInfos :: [TimeInfo] -> Monitor [[String]] +showTimeInfos = mapM showTimeInfo + +runTop :: TimesRef -> Float -> [String] -> Monitor String +runTop tref scale _ = do + (no, ps, ms) <- io $ topProcesses tref scale + pstr <- showTimeInfos ps + mstr <- showMemInfos ms + parseTemplate $ show no : concat (zipWith (++) pstr mstr) ++ repeat "N/A" + +startTop :: [String] -> Int -> (String -> IO ()) -> IO () +startTop a r cb = do + cr <- getSysVar ClockTick + c <- getCurrentTime + tref <- newIORef ([], c) + let scale = fromIntegral cr / 100 + _ <- topProcesses tref scale + runM a topConfig (runTop tref scale) r cb diff --git a/src/Xmobar/Plugins/Monitors/UVMeter.hs b/src/Xmobar/Plugins/Monitors/UVMeter.hs new file mode 100644 index 0000000..079177f --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/UVMeter.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.UVMeter +-- Copyright : (c) Róman Joost +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Róman Joost +-- Stability : unstable +-- Portability : unportable +-- +-- An australian uv monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.UVMeter where + +import Xmobar.Plugins.Monitors.Common + +import qualified Control.Exception as CE +import Network.HTTP.Conduit + (parseRequest, newManager, tlsManagerSettings, httpLbs, + responseBody) +import Data.ByteString.Lazy.Char8 as B +import Text.Read (readMaybe) +import Text.Parsec +import Text.Parsec.String +import Control.Monad (void) + + +uvConfig :: IO MConfig +uvConfig = mkMConfig + "<station>" -- template + ["station" -- available replacements + ] + +newtype UvInfo = UV { index :: String } + deriving (Show) + +uvURL :: String +uvURL = "https://uvdata.arpansa.gov.au/xml/uvvalues.xml" + +getData :: IO String +getData = + CE.catch (do request <- parseRequest uvURL + manager <- newManager tlsManagerSettings + res <- httpLbs request manager + return $ B.unpack $ responseBody res) + errHandler + where errHandler + :: CE.SomeException -> IO String + errHandler _ = return "<Could not retrieve data>" + +textToXMLDocument :: String -> Either ParseError [XML] +textToXMLDocument = parse document "" + +formatUVRating :: Maybe Float -> Monitor String +formatUVRating Nothing = getConfigValue naString +formatUVRating (Just x) = do + uv <- showWithColors show x + parseTemplate [uv] + +getUVRating :: String -> [XML] -> Maybe Float +getUVRating locID (Element "stations" _ y:_) = getUVRating locID y +getUVRating locID (Element "location" [Attribute attr] ys:xs) + | locID == snd attr = getUVRating locID ys + | otherwise = getUVRating locID xs +getUVRating _ (Element "index" [] [Body rate]:_) = readMaybe rate +getUVRating locID (_:xs) = getUVRating locID xs +getUVRating _ [] = Nothing + + +runUVMeter :: [String] -> Monitor String +runUVMeter [] = return "N.A." +runUVMeter (s:_) = do + resp <- io getData + case textToXMLDocument resp of + Right doc -> formatUVRating (getUVRating s doc) + Left _ -> getConfigValue naString + +-- | XML Parsing code comes here. +-- This is a very simple XML parser to just deal with the uvvalues.xml +-- provided by ARPANSA. If you work on a new plugin which needs an XML +-- parser perhaps consider using a real XML parser and refactor this +-- plug-in to us it as well. +-- +-- Note: This parser can not deal with short tags. +-- +-- Kudos to: Charlie Harvey for his article about writing an XML Parser +-- with Parsec. +-- + +type AttrName = String +type AttrValue = String + +newtype Attribute = Attribute (AttrName, AttrValue) + deriving (Show) + +data XML = Element String [Attribute] [XML] + | Decl String + | Body String + deriving (Show) + +-- | parse the document +-- +document :: Parser [XML] +document = do + spaces + y <- try xmlDecl <|> tag + spaces + x <- many tag + spaces + return (y : x) + +-- | parse any tags +-- +tag :: Parser XML +tag = do + char '<' + spaces + name <- many (letter <|> digit) + spaces + attr <- many attribute + spaces + string ">" + eBody <- many elementBody + endTag name + spaces + return (Element name attr eBody) + +xmlDecl :: Parser XML +xmlDecl = do + void $ manyTill anyToken (string "<?xml") -- ignore the byte order mark + decl <- many (noneOf "?>") + string "?>" + return (Decl decl) + +elementBody :: Parser XML +elementBody = spaces *> try tag <|> text + +endTag :: String -> Parser String +endTag str = string "</" *> string str <* char '>' + +text :: Parser XML +text = Body <$> many1 (noneOf "><") + +attribute :: Parser Attribute +attribute = do + name <- many (noneOf "= />") + spaces + char '=' + spaces + char '"' + value <- many (noneOf "\"") + char '"' + spaces + return (Attribute (name, value)) diff --git a/src/Xmobar/Plugins/Monitors/Uptime.hs b/src/Xmobar/Plugins/Monitors/Uptime.hs new file mode 100644 index 0000000..235fc85 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Uptime.hs @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Plugins.Monitors.Uptime +-- Copyright : (c) 2010 Jose Antonio Ortega Ruiz +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- Created: Sun Dec 12, 2010 20:26 +-- +-- +-- Uptime +-- +------------------------------------------------------------------------------ + + +module Xmobar.Plugins.Monitors.Uptime (uptimeConfig, runUptime) where + +import Xmobar.Plugins.Monitors.Common + +import qualified Data.ByteString.Lazy.Char8 as B + +uptimeConfig :: IO MConfig +uptimeConfig = mkMConfig "Up <days>d <hours>h <minutes>m" + ["days", "hours", "minutes", "seconds"] + +readUptime :: IO Float +readUptime = + fmap (read . B.unpack . head . B.words) (B.readFile "/proc/uptime") + +secsPerDay :: Integer +secsPerDay = 24 * 3600 + +uptime :: Monitor [String] +uptime = do + t <- io readUptime + u <- getConfigValue useSuffix + let tsecs = floor t + secs = tsecs `mod` secsPerDay + days = tsecs `quot` secsPerDay + hours = secs `quot` 3600 + mins = (secs `mod` 3600) `div` 60 + ss = secs `mod` 60 + str x s = if u then show x ++ s else show x + mapM (`showWithColors'` days) + [str days "d", str hours "h", str mins "m", str ss "s"] + +runUptime :: [String] -> Monitor String +runUptime _ = uptime >>= parseTemplate diff --git a/src/Xmobar/Plugins/Monitors/Volume.hs b/src/Xmobar/Plugins/Monitors/Volume.hs new file mode 100644 index 0000000..1d3281c --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Volume.hs @@ -0,0 +1,196 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Volume +-- Copyright : (c) 2011, 2013, 2015, 2018 Thomas Tuegel +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A monitor for ALSA soundcards +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Volume + ( runVolume + , runVolumeWith + , volumeConfig + , options + , defaultOpts + , VolumeOpts + ) where + +import Control.Applicative ((<$>)) +import Control.Monad ( liftM2, liftM3, mplus ) +import Data.Traversable (sequenceA) +import Xmobar.Plugins.Monitors.Common +import Sound.ALSA.Mixer +import qualified Sound.ALSA.Exception as AE +import System.Console.GetOpt + +volumeConfig :: IO MConfig +volumeConfig = mkMConfig "Vol: <volume>% <status>" + ["volume", "volumebar", "volumevbar", "dB","status", "volumeipat"] + + +data VolumeOpts = VolumeOpts + { onString :: String + , offString :: String + , onColor :: Maybe String + , offColor :: Maybe String + , highDbThresh :: Float + , lowDbThresh :: Float + , volumeIconPattern :: Maybe IconPattern + } + +defaultOpts :: VolumeOpts +defaultOpts = VolumeOpts + { onString = "[on] " + , offString = "[off]" + , onColor = Just "green" + , offColor = Just "red" + , highDbThresh = -5.0 + , lowDbThresh = -30.0 + , volumeIconPattern = Nothing + } + +options :: [OptDescr (VolumeOpts -> VolumeOpts)] +options = + [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" + , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") "" + , Option "" ["lowd"] (ReqArg (\x o -> o { lowDbThresh = read x }) "") "" + , 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 +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +percent :: Integer -> Integer -> Integer -> Float +percent v' lo' hi' = (v - lo) / (hi - lo) + where v = fromIntegral v' + lo = fromIntegral lo' + hi = fromIntegral hi' + +formatVol :: Integer -> Integer -> Integer -> Monitor String +formatVol lo hi v = + showPercentWithColors $ percent v lo hi + +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) + -> Monitor String +switchHelper opts cHelp strHelp = return $ + colorHelper (cHelp opts) + ++ strHelp opts + ++ maybe "" (const "</fc>") (cHelp opts) + +formatSwitch :: VolumeOpts -> Bool -> Monitor String +formatSwitch opts True = switchHelper opts onColor onString +formatSwitch opts False = switchHelper opts offColor offString + +colorHelper :: Maybe String -> String +colorHelper = maybe "" (\c -> "<fc=" ++ c ++ ">") + +formatDb :: VolumeOpts -> Integer -> Monitor String +formatDb opts dbi = do + h <- getConfigValue highColor + m <- getConfigValue normalColor + l <- getConfigValue lowColor + d <- getConfigValue decDigits + let db = fromIntegral dbi / 100.0 + digits = showDigits d db + startColor | db >= highDbThresh opts = colorHelper h + | db < lowDbThresh opts = colorHelper l + | otherwise = colorHelper m + stopColor | null startColor = "" + | otherwise = "</fc>" + return $ startColor ++ digits ++ stopColor + +runVolume :: String -> String -> [String] -> Monitor String +runVolume mixerName controlName argv = do + opts <- io $ parseOpts argv + runVolumeWith opts mixerName controlName + +runVolumeWith :: VolumeOpts -> String -> String -> Monitor String +runVolumeWith opts mixerName controlName = do + (lo, hi, val, db, sw) <- io readMixer + 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 + ipat <- liftMonitor $ liftM3 (formatVolDStr $ volumeIconPattern opts) lo hi val + parseTemplate [p, b, v, d, s, ipat] + + where + + readMixer = + AE.catch (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)) + (const $ return (Nothing, Nothing, Nothing, Nothing, Nothing)) + + volumeControl :: Maybe Control -> Maybe Volume + volumeControl c = (playback . volume =<< c) + `mplus` (capture . volume =<< c) + `mplus` (common . volume =<< c) + + switchControl :: Maybe Control -> Maybe Switch + switchControl c = (playback . switch =<< c) + `mplus` (capture . switch =<< c) + `mplus` (common . switch =<< c) + + liftMaybe :: Maybe (IO (a,b)) -> IO (Maybe a, Maybe b) + liftMaybe = fmap (liftM2 (,) (fmap fst) (fmap snd)) . sequenceA + + liftMonitor :: Maybe (Monitor String) -> Monitor String + liftMonitor Nothing = unavailable + liftMonitor (Just m) = m + + channel v r = AE.catch (getChannel FrontLeft v) (const $ return $ Just r) + + getDB :: Maybe Volume -> IO (Maybe Integer) + getDB Nothing = return Nothing + getDB (Just v) = channel (dB v) 0 + + getVal :: Maybe Volume -> IO (Maybe Integer) + getVal Nothing = return Nothing + getVal (Just v) = channel (value v) 0 + + getSw :: Maybe Switch -> IO (Maybe Bool) + getSw Nothing = return Nothing + getSw (Just s) = channel s False + + getFormatDB :: VolumeOpts -> Maybe Integer -> Monitor String + getFormatDB _ Nothing = unavailable + getFormatDB opts' (Just d) = formatDb opts' d + + getFormatSwitch :: VolumeOpts -> Maybe Bool -> Monitor String + getFormatSwitch _ Nothing = unavailable + getFormatSwitch opts' (Just sw) = formatSwitch opts' sw + + unavailable = getConfigValue naString diff --git a/src/Xmobar/Plugins/Monitors/Weather.hs b/src/Xmobar/Plugins/Monitors/Weather.hs new file mode 100644 index 0000000..cb5bf07 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Weather.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Weather +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A weather monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Weather where + +import Xmobar.Plugins.Monitors.Common + +import qualified Control.Exception as CE + +#ifdef HTTP_CONDUIT +import Network.HTTP.Conduit +import Network.HTTP.Types.Status +import Network.HTTP.Types.Method +import qualified Data.ByteString.Lazy.Char8 as B +#else +import Network.HTTP +#endif + +import Text.ParserCombinators.Parsec + +weatherConfig :: IO MConfig +weatherConfig = mkMConfig + "<station>: <tempC>C, rh <rh>% (<hour>)" -- template + ["station" -- available replacements + , "stationState" + , "year" + , "month" + , "day" + , "hour" + , "windCardinal" + , "windAzimuth" + , "windMph" + , "windKnots" + , "windKmh" + , "windMs" + , "visibility" + , "skyCondition" + , "tempC" + , "tempF" + , "dewPointC" + , "dewPointF" + , "rh" + , "pressure" + ] + +data WindInfo = + WindInfo { + windCardinal :: String -- cardinal direction + , windAzimuth :: String -- azimuth direction + , windMph :: String -- speed (MPH) + , windKnots :: String -- speed (knot) + , windKmh :: String -- speed (km/h) + , windMs :: String -- speed (m/s) + } deriving (Show) + +data WeatherInfo = + WI { stationPlace :: String + , stationState :: String + , year :: String + , month :: String + , day :: String + , hour :: String + , windInfo :: WindInfo + , visibility :: String + , skyCondition :: String + , tempC :: Int + , tempF :: Int + , dewPointC :: Int + , dewPointF :: Int + , humidity :: Int + , pressure :: Int + } deriving (Show) + +pTime :: Parser (String, String, String, String) +pTime = do y <- getNumbersAsString + char '.' + m <- getNumbersAsString + char '.' + d <- getNumbersAsString + char ' ' + (h:hh:mi:mimi) <- getNumbersAsString + char ' ' + return (y, m, d ,h:hh:":"++mi:mimi) + +noWind :: WindInfo +noWind = WindInfo "μ" "μ" "0" "0" "0" "0" + +pWind :: Parser WindInfo +pWind = + let tospace = manyTill anyChar (char ' ') + toKmh knots = knots $* 1.852 + toMs knots = knots $* 0.514 + ($*) :: String -> Double -> String + op1 $* op2 = show (round ((read op1::Double) * op2)::Integer) + + -- Occasionally there is no wind and a METAR report gives simply, "Wind: Calm:0" + wind0 = do manyTill skipRestOfLine (string "Wind: Calm:0") + return noWind + windVar = do manyTill skipRestOfLine (string "Wind: Variable at ") + mph <- tospace + string "MPH (" + knot <- tospace + manyTill anyChar newline + return $ WindInfo "μ" "μ" mph knot (toKmh knot) (toMs knot) + 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 $ WindInfo cardinal azimuth mph knot (toKmh knot) (toMs knot) + in try wind0 <|> try windVar <|> try wind <|> return noWind + +pTemp :: Parser (Int, Int) +pTemp = do let num = digit <|> char '-' <|> char '.' + f <- manyTill num $ char ' ' + manyTill anyChar $ char '(' + c <- manyTill num $ char ' ' + skipRestOfLine + return (floor (read c :: Double), floor (read f :: Double)) + +pRh :: Parser Int +pRh = do s <- manyTill digit (char '%' <|> char '.') + return $ read s + +pPressure :: Parser Int +pPressure = do manyTill anyChar $ char '(' + s <- manyTill digit $ 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, 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 <- pWind + v <- getAfterString "Visibility: " + sk <- getAfterString "Sky conditions: " + skipTillString "Temperature: " + (tC,tF) <- pTemp + 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 dC dF rh p] + +defUrl :: String +-- "http://weather.noaa.gov/pub/data/observations/metar/decoded/" +defUrl = "http://tgftp.nws.noaa.gov/data/observations/metar/decoded/" + +stationUrl :: String -> String +stationUrl station = defUrl ++ station ++ ".TXT" + +getData :: String -> IO String +#ifdef HTTP_CONDUIT +getData station = CE.catch (do + manager <- newManager tlsManagerSettings + request <- parseUrl $ stationUrl station + res <- httpLbs request manager + return $ B.unpack $ responseBody res + ) errHandler + where errHandler :: CE.SomeException -> IO String + errHandler _ = return "<Could not retrieve data>" +#else +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>" +#endif + +formatWeather :: [WeatherInfo] -> Monitor String +formatWeather [WI st ss y m d h (WindInfo wc wa wm wk wkh wms) v sk tC tF dC dF r p] = + do cel <- showWithColors show tC + far <- showWithColors show tF + parseTemplate [st, ss, y, m, d, h, wc, wa, wm, wk, wkh, wms, 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 +#ifdef HTTP_CONDUIT +weatherReady str = do + initRequest <- parseUrl $ stationUrl $ head str + let request = initRequest{method = methodHead} + io $ CE.catch ( do + manager <- newManager tlsManagerSettings + res <- httpLbs request manager + return $ checkResult $responseStatus res ) errHandler + where errHandler :: CE.SomeException -> IO Bool + errHandler _ = return False + checkResult status + | statusIsServerError status = False + | statusIsClientError status = False + | otherwise = True +#else +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 +#endif diff --git a/src/Xmobar/Plugins/Monitors/Wireless.hs b/src/Xmobar/Plugins/Monitors/Wireless.hs new file mode 100644 index 0000000..545f6bc --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Wireless.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Wireless +-- Copyright : (c) Jose Antonio Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose Antonio Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A monitor reporting ESSID and link quality for wireless interfaces +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Wireless (wirelessConfig, runWireless) where + +import System.Console.GetOpt + +import Xmobar.Plugins.Monitors.Common +import Network.IWlib + +newtype 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", "qualityvbar", "qualityipat"] + +runWireless :: String -> [String] -> Monitor String +runWireless iface args = do + opts <- io $ parseOpts args + iface' <- if "" == iface then io findInterface else return iface + wi <- io $ getWirelessInfo iface' + na <- getConfigValue naString + let essid = wiEssid wi + qlty = fromIntegral $ wiQuality wi + e = if essid == "" then na else essid + ep <- showWithPadding e + q <- if qlty >= 0 + then showPercentWithColors (qlty / 100) + else showWithPadding "" + qb <- showPercentBar qlty (qlty / 100) + qvb <- showVerticalBar qlty (qlty / 100) + qipat <- showIconPattern (qualityIconPattern opts) (qlty / 100) + parseTemplate [ep, q, qb, qvb, qipat] + +findInterface :: IO String +findInterface = do + c <- readFile "/proc/net/wireless" + let nds = lines c + return $ if length nds > 2 then takeWhile (/= 'c') (nds!!2) else [] diff --git a/src/Xmobar/Plugins/PipeReader.hs b/src/Xmobar/Plugins/PipeReader.hs new file mode 100644 index 0000000..7166163 --- /dev/null +++ b/src/Xmobar/Plugins/PipeReader.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.PipeReader +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from named pipes +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.PipeReader where + +import System.IO +import Xmobar.Plugins +import Xmobar.Environment +import System.Posix.Files +import Control.Concurrent(threadDelay) +import Control.Exception +import Control.Monad(forever, unless) +import Control.Applicative ((<$>)) + +data PipeReader = PipeReader String String + deriving (Read, Show) + +instance Exec PipeReader where + alias (PipeReader _ a) = a + start (PipeReader p _) cb = do + (def, pipe) <- split ':' <$> expandEnv p + unless (null def) (cb def) + checkPipe pipe + h <- openFile pipe ReadWriteMode + forever (hGetLineSafe h >>= cb) + where + split c xs | c `elem` xs = let (pre, post) = span (c /=) xs + in (pre, dropWhile (c ==) post) + | otherwise = ([], xs) + +checkPipe :: FilePath -> IO () +checkPipe file = + handle (\(SomeException _) -> waitForPipe) $ do + status <- getFileStatus file + unless (isNamedPipe status) waitForPipe + where waitForPipe = threadDelay 1000000 >> checkPipe file diff --git a/src/Xmobar/Plugins/StdinReader.hs b/src/Xmobar/Plugins/StdinReader.hs new file mode 100644 index 0000000..372e4f9 --- /dev/null +++ b/src/Xmobar/Plugins/StdinReader.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.StdinReader +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from `stdin`. +-- +-- Exports: +-- - `StdinReader` to safely display stdin content (striping actions). +-- - `UnsafeStdinReader` to display stdin content as-is. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.StdinReader (StdinReader(..)) where + +import Prelude +import System.Posix.Process +import System.Exit +import System.IO +import Control.Exception (SomeException(..), handle) +import Xmobar.Plugins +import Xmobar.Actions (stripActions) + +data StdinReader = StdinReader | UnsafeStdinReader + deriving (Read, Show) + +instance Exec StdinReader where + start stdinReader cb = do + s <- handle (\(SomeException e) -> do hPrint stderr e; return "") + (hGetLineSafe stdin) + cb $ escape stdinReader s + eof <- isEOF + if eof + then exitImmediately ExitSuccess + else start stdinReader cb + +escape :: StdinReader -> String -> String +escape StdinReader = stripActions +escape UnsafeStdinReader = id diff --git a/src/Xmobar/Plugins/Utils.hs b/src/Xmobar/Plugins/Utils.hs new file mode 100644 index 0000000..6546c15 --- /dev/null +++ b/src/Xmobar/Plugins/Utils.hs @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Plugins.Utils +-- Copyright: (c) 2010 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: Jose A Ortega Ruiz <jao@gnu.org> +-- Stability: unstable +-- Portability: unportable +-- Created: Sat Dec 11, 2010 20:55 +-- +-- +-- Miscellaneous utility functions +-- +------------------------------------------------------------------------------ + + +module Xmobar.Plugins.Utils (expandHome, changeLoop, safeHead) where + +import Control.Monad +import Control.Concurrent.STM + +import System.Environment +import System.FilePath + + +expandHome :: FilePath -> IO FilePath +expandHome ('~':'/':path) = fmap (</> path) (getEnv "HOME") +expandHome p = return p + +changeLoop :: Eq a => STM a -> (a -> IO ()) -> IO () +changeLoop s f = atomically s >>= go + where + go old = do + f old + go =<< atomically (do + new <- s + guard (new /= old) + return new) + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x diff --git a/src/Xmobar/Plugins/XMonadLog.hs b/src/Xmobar/Plugins/XMonadLog.hs new file mode 100644 index 0000000..6bbba59 --- /dev/null +++ b/src/Xmobar/Plugins/XMonadLog.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.StdinReader +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin to display information from _XMONAD_LOG, specified at +-- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.XMonadLog (XMonadLog(..)) where + +import Control.Monad +import Graphics.X11 +import Graphics.X11.Xlib.Extras +import Xmobar.Plugins +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar) +import Xmobar.XUtil (nextEvent') +import Xmobar.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" + 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 + + root <- rootWindow d (defaultScreen d) + selectInput d root propertyChangeMask + + let update = do + mwp <- getWindowProperty8 d xlog root + maybe (return ()) (cb . sanitize . decodeCChar) mwp + + update + + allocaXEvent $ \ep -> forever $ do + nextEvent' d ep + e <- getEvent ep + case e of + PropertyEvent { ev_atom = a } | a == xlog -> update + _ -> return () + + return () + +decodeCChar :: [CChar] -> String +#ifdef UTF8 +#undef UTF8 +decodeCChar = UTF8.decode . map fromIntegral +#define UTF8 +#else +decodeCChar = map (toEnum . fromIntegral) +#endif diff --git a/src/Xmobar/Runnable.hs b/src/Xmobar/Runnable.hs new file mode 100644 index 0000000..164f661 --- /dev/null +++ b/src/Xmobar/Runnable.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Runnable +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- The existential type to store the list of commands to be executed. +-- I must thank Claus Reinke for the help in understanding the mysteries of +-- reading existential types. The Read instance of Runnable must be credited to +-- him. +-- +-- See here: +-- http:\/\/www.haskell.org\/pipermail\/haskell-cafe\/2007-July\/028227.html +-- +----------------------------------------------------------------------------- + +module Xmobar.Runnable where + +import Control.Monad +import Text.Read +import Xmobar.Config (runnableTypes) +import Xmobar.Commands + +data Runnable = forall r . (Exec r, Read r, Show r) => Run r + +instance Exec Runnable where + start (Run a) = start a + alias (Run a) = alias a + trigger (Run a) = trigger a + +instance Show Runnable where + show (Run x) = show x + +instance Read Runnable where + readPrec = readRunnable + +class ReadAsAnyOf ts ex where + -- | Reads an existential type as any of hidden types ts + readAsAnyOf :: ts -> ReadPrec ex + +instance ReadAsAnyOf () ex where + readAsAnyOf ~() = mzero + +instance (Read t, Exec t, ReadAsAnyOf ts Runnable) => ReadAsAnyOf (t,ts) Runnable where + readAsAnyOf ~(t,ts) = r t `mplus` readAsAnyOf ts + where r ty = do { m <- readPrec; return (Run (m `asTypeOf` ty)) } + +-- | The 'Prelude.Read' parser for the 'Runnable' existential type. It +-- needs an 'Prelude.undefined' with a type signature containing the +-- list of all possible types hidden within 'Runnable'. See 'Config.runnableTypes'. +-- Each hidden type must have a 'Prelude.Read' instance. +readRunnable :: ReadPrec Runnable +readRunnable = prec 10 $ do + Ident "Run" <- lexP + parens $ readAsAnyOf runnableTypes diff --git a/src/Xmobar/Runnable.hs-boot b/src/Xmobar/Runnable.hs-boot new file mode 100644 index 0000000..0f67322 --- /dev/null +++ b/src/Xmobar/Runnable.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Xmobar.Runnable where +import Xmobar.Commands + +data Runnable = forall r . (Exec r,Read r,Show r) => Run r + +instance Read Runnable +instance Exec Runnable diff --git a/src/Xmobar/Signal.hs b/src/Xmobar/Signal.hs new file mode 100644 index 0000000..bdc4be1 --- /dev/null +++ b/src/Xmobar/Signal.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Signal +-- Copyright : (c) Andrea Rosatto +-- : (c) Jose A. Ortega Ruiz +-- : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Signal handling, including DBUS when available +-- +----------------------------------------------------------------------------- + +module Xmobar.Signal where + +import Data.Foldable (for_) +import Data.Typeable (Typeable) +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import System.Posix.Signals +import Graphics.X11.Types (Button) +import Graphics.X11.Xlib.Types (Position) +import System.IO + +#ifdef DBUS +import DBus (IsVariant(..)) +import Control.Monad ((>=>)) +#endif + +import Xmobar.Plugins.Utils (safeHead) + +data WakeUp = WakeUp deriving (Show,Typeable) +instance Exception WakeUp + +data SignalType = Wakeup + | Reposition + | ChangeScreen + | Hide Int + | Reveal Int + | Toggle Int + | TogglePersistent + | Action Button Position + deriving (Read, Show) + +#ifdef DBUS +instance IsVariant SignalType where + toVariant = toVariant . show + fromVariant = fromVariant >=> parseSignalType +#endif + +parseSignalType :: String -> Maybe SignalType +parseSignalType = fmap fst . safeHead . reads + +-- | Signal handling +setupSignalHandler :: IO (TMVar SignalType) +setupSignalHandler = do + tid <- newEmptyTMVarIO + installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing + installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing + return tid + +updatePosHandler :: TMVar SignalType -> IO () +updatePosHandler sig = do + atomically $ putTMVar sig Reposition + return () + +changeScreenHandler :: TMVar SignalType -> IO () +changeScreenHandler sig = do + atomically $ putTMVar sig ChangeScreen + return () + + +-- | Ensures that the given IO action runs its cleanup actions ('bracket' etc.), +-- even if a signal is caught. +-- +-- An exception will be thrown on the thread that called this function when a +-- signal is caught. +withDeferSignals :: IO a -> IO a +withDeferSignals thing = do + threadId <- myThreadId + caughtSignal <- newEmptyMVar + + let signals = + filter (not . flip inSignalSet reservedSignals) + [ sigQUIT + , sigTERM + --, sigINT -- Handler already installed by GHC + --, sigPIPE -- Handler already installed by GHC + --, sigUSR1 -- Handled by setupSignalHandler + --, sigUSR2 -- Handled by setupSignalHandler + + -- One of the following appears to cause instability, see #360 + --, sigHUP + --, sigILL + --, sigABRT + --, sigFPE + --, sigSEGV + --, sigALRM + --, sigBUS + --, sigPOLL + --, sigPROF + --, sigSYS + --, sigTRAP + --, sigVTALRM + --, sigXCPU + --, sigXFSZ + ] + + for_ signals $ \s -> + + installHandler s + (Catch $ do + tryPutMVar caughtSignal s + hPutStrLn stderr ("xmobar: Caught signal "++show s++"; exiting...") + throwTo threadId ThreadKilled) + Nothing + + thing `finally` do + s0 <- tryReadMVar caughtSignal + case s0 of + Nothing -> pure () + Just s -> do + -- Run the default handler for the signal + -- hPutStrLn stderr ("xmobar: Running default handler for signal "++show s) + installHandler s Default Nothing + raiseSignal s diff --git a/src/Xmobar/StatFS.hsc b/src/Xmobar/StatFS.hsc new file mode 100644 index 0000000..25de0df --- /dev/null +++ b/src/Xmobar/StatFS.hsc @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- Module : StatFS +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A binding to C's statvfs(2) +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} + + +module Xmobar.StatFS ( FileSystemStats(..), getFileSystemStats ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Data.ByteString (useAsCString) +import Data.ByteString.Char8 (pack) + +#if defined (__FreeBSD__) || defined (__OpenBSD__) || defined (__APPLE__) || defined (__DragonFly__) +#define IS_BSD_SYSTEM +#endif + +#ifdef IS_BSD_SYSTEM +# include <sys/param.h> +# include <sys/mount.h> +#else +# include <sys/vfs.h> +#endif + +data FileSystemStats = FileSystemStats { + fsStatBlockSize :: Integer + -- ^ Optimal transfer block size. + , fsStatBlockCount :: Integer + -- ^ Total data blocks in file system. + , fsStatByteCount :: Integer + -- ^ Total bytes in file system. + , fsStatBytesFree :: Integer + -- ^ Free bytes in file system. + , fsStatBytesAvailable :: Integer + -- ^ Free bytes available to non-superusers. + , fsStatBytesUsed :: Integer + -- ^ Bytes used. + } deriving (Show, Eq) + +data CStatfs + +#ifdef IS_BSD_SYSTEM +foreign import ccall unsafe "sys/mount.h statfs" +#else +foreign import ccall unsafe "sys/vfs.h statvfs" +#endif + c_statfs :: CString -> Ptr CStatfs -> IO CInt + +toI :: CULong -> Integer +toI = toInteger + +getFileSystemStats :: String -> IO (Maybe FileSystemStats) +getFileSystemStats path = + allocaBytes (#size struct statfs) $ \vfs -> + useAsCString (pack path) $ \cpath -> do + res <- c_statfs cpath vfs + if res /= 0 then return Nothing + else do + bsize <- (#peek struct statfs, f_bsize) vfs + bcount <- (#peek struct statfs, f_blocks) vfs + bfree <- (#peek struct statfs, f_bfree) vfs + bavail <- (#peek struct statfs, f_bavail) vfs + let bpb = toI bsize + return $ Just FileSystemStats + { fsStatBlockSize = bpb + , fsStatBlockCount = toI bcount + , fsStatByteCount = toI bcount * bpb + , fsStatBytesFree = toI bfree * bpb + , fsStatBytesAvailable = toI bavail * bpb + , fsStatBytesUsed = toI (bcount - bfree) * bpb + } diff --git a/src/Xmobar/Window.hs b/src/Xmobar/Window.hs new file mode 100644 index 0000000..c8228de --- /dev/null +++ b/src/Xmobar/Window.hs @@ -0,0 +1,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Window +-- Copyright : (c) 2011-18 Jose A. Ortega Ruiz +-- : (c) 2012 Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Window manipulation functions +-- +----------------------------------------------------------------------------- + +module Xmobar.Window where + +import Prelude +import Control.Applicative ((<$>)) +import Control.Monad (when, unless) +import Graphics.X11.Xlib hiding (textExtents) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama +import Foreign.C.Types (CLong) + +import Data.Function (on) +import Data.List (maximumBy) +import Data.Maybe (fromMaybe) +import System.Posix.Process (getProcessID) + +import Xmobar.Config +import Xmobar.XUtil + +-- $window + +-- | The function to create the initial window +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) +createWin d fs c = do + let dflt = defaultScreen d + srs <- getScreenInfo d + rootw <- rootWindow d dflt + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + 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 + when (lowerOnStart c) $ lowerWindow d win + unless (hideOnStart c) $ showWindow r c d win + return (r,win) + +-- | Updates the size and position of the window +repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle +repositionWin d win fs c = do + srs <- getScreenInfo d + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + 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 :: 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 + TopW a i -> Rectangle (ax a i) ry (nw i) h + TopSize a i ch -> Rectangle (ax a i) ry (nw i) (mh ch) + Bottom -> Rectangle rx ny rw h + BottomW a i -> Rectangle (ax a i) ny (nw i) h + 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 c p'' [scr] ht + where + (scr@(Rectangle rx ry rw rh), 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) + remwid i = rw - pw (fi i) + ax L = const rx + ax R = right + ax C = center + pw i = rw * min 100 i `div` 100 + nw = fi . pw . fi + h = fi 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 + let mkatom n = internAtom d n False + card <- mkatom "CARDINAL" + atom <- mkatom "ATOM" + + setTextProperty d w (wmClass c) wM_CLASS + setTextProperty d w (wmName c) wM_NAME + + wtype <- mkatom "_NET_WM_WINDOW_TYPE" + dock <- mkatom "_NET_WM_WINDOW_TYPE_DOCK" + changeProperty32 d w wtype atom propModeReplace [fi dock] + + when (allDesktops c) $ do + desktop <- mkatom "_NET_WM_DESKTOP" + changeProperty32 d w desktop card propModeReplace [0xffffffff] + + pid <- mkatom "_NET_WM_PID" + getProcessID >>= changeProperty32 d w pid card propModeReplace . return . fi + +setStruts' :: Display -> Window -> [Foreign.C.Types.CLong] -> IO () +setStruts' d w svs = do + let mkatom n = internAtom d n False + card <- mkatom "CARDINAL" + pstrut <- mkatom "_NET_WM_STRUT_PARTIAL" + strut <- mkatom "_NET_WM_STRUT" + changeProperty32 d w pstrut card propModeReplace svs + changeProperty32 d w strut card propModeReplace (take 4 svs) + +setStruts :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () +setStruts r c d w rs = do + let svs = map fi $ getStrutValues r (position c) (getRootWindowHeight rs) + setStruts' d w svs + +getRootWindowHeight :: [Rectangle] -> Int +getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) + where + getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) + +getStrutValues :: Rectangle -> XPosition -> Int -> [Int] +getStrutValues r@(Rectangle x y w h) p rwh = + case p of + OnScreen _ p' -> getStrutValues r p' rwh + Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomP _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + Static {} -> getStaticStrutValues p rwh + where st = fi y + fi h + sb = rwh - fi y + nx = fi x + nw = fi (x + fi w - 1) + +-- get some reaonable strut values for static placement. +getStaticStrutValues :: XPosition -> Int -> [Int] +getStaticStrutValues (Static cx cy cw ch) rwh + -- if the yPos is in the top half of the screen, then assume a Top + -- placement, otherwise, it's a Bottom placement + | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] + | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] + where st = cy + ch + sb = rwh - cy + xs = cx -- a simple calculation for horizontal (x) placement + xe = xs + cw +getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + +drawBorder :: Border -> Int -> Display -> Drawable -> GC -> Pixel + -> Dimension -> Dimension -> IO () +drawBorder b lw d p gc c wi ht = case b of + NoBorder -> return () + 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 mp = fi m + pad = 2 * fi mp + fi lw + 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 + setStruts' d w (replicate 12 0) + unmapWindow d w >> sync d False + +showWindow :: Rectangle -> Config -> Display -> Window -> IO () +showWindow r c d w = do + mapWindow d w + getScreenInfo d >>= setStruts r c d w + sync d False + +isMapped :: Display -> Window -> IO Bool +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/Xmobar/XPMFile.hsc b/src/Xmobar/XPMFile.hsc new file mode 100644 index 0000000..03d534f --- /dev/null +++ b/src/Xmobar/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 Xmobar.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/Xmobar/XUtil.hsc b/src/Xmobar/XUtil.hsc new file mode 100644 index 0000000..05e6fad --- /dev/null +++ b/src/Xmobar/XUtil.hsc @@ -0,0 +1,235 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XUtil +-- Copyright : (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz +-- (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.XUtil + ( XFont + , initFont + , initCoreFont + , initUtf8Font + , textExtents + , textWidth + , printString + , newWindow + , nextEvent' + , readFileSafe + , hGetLineSafe + , io + , fi + ) where + +import Control.Concurrent +import Control.Monad (when) +import Control.Monad.Trans +import Control.Exception (SomeException, handle) +import Data.List +import Foreign +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import System.Mem.Weak ( addFinalizer ) +import System.Posix.Types (Fd(..)) +import System.IO + +#if defined XFT || defined UTF8 +# if __GLASGOW_HASKELL__ < 612 +import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine) +# else +import qualified System.IO as UTF8 (readFile,hGetLine) +# endif +#endif +#if defined XFT +import Xmobar.MinXft +import Graphics.X11.Xrender +#endif + +import Xmobar.ColorCache + +readFileSafe :: FilePath -> IO String +#if defined XFT || defined UTF8 +readFileSafe = UTF8.readFile +#else +readFileSafe = readFile +#endif + +hGetLineSafe :: Handle -> IO String +#if defined XFT || defined UTF8 +hGetLineSafe = UTF8.hGetLine +#else +hGetLineSafe = hGetLine +#endif + +-- Hide the Core Font/Xft switching here +data XFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft [AXftFont] +#endif + +-- | When initFont gets a font name that starts with 'xft:' it switchs +-- to the Xft backend Example: 'xft:Sans-10' +initFont :: Display -> String -> IO XFont +initFont d s = + let xftPrefix = "xft:" in + if xftPrefix `isPrefixOf` s then +#ifdef XFT + fmap Xft $ initXftFont d s +#else + do + hPutStrLn stderr $ "Warning: Xmobar must be built with " + ++ "the with_xft flag to support font '" ++ s + ++ ".' Falling back on default." + initFont d miscFixedFont +#endif + else +#if defined UTF8 || __GLASGOW_HASKELL__ >= 612 + fmap Utf8 $ initUtf8Font d s +#else + fmap Core $ initCoreFont d s +#endif + +miscFixedFont :: String +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. +initCoreFont :: Display -> String -> IO FontStruct +initCoreFont d s = do + f <- handle fallBack getIt + addFinalizer f (freeFont d f) + return f + where getIt = loadQueryFont d s + fallBack :: SomeException -> IO FontStruct + fallBack = const $ loadQueryFont d miscFixedFont + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initUtf8Font :: Display -> String -> IO FontSet +initUtf8Font d s = do + setupLocale + (_,_,f) <- handle fallBack getIt + addFinalizer f (freeFontSet d f) + return f + where getIt = createFontSet d s + fallBack :: SomeException -> IO ([String], String, FontSet) + fallBack = const $ createFontSet d miscFixedFont + +#ifdef XFT +initXftFont :: Display -> String -> IO [AXftFont] +initXftFont d s = do + setupLocale + let fontNames = wordsBy (== ',') (drop 4 s) + mapM openFont fontNames + 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 +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 + return $ xglyphinfo_xOff gi +#endif + +textExtents :: XFont -> String -> IO (Int32,Int32) +textExtents (Core fs) s = do + let (_,a,d,_) = Xlib.textExtents fs s + return (a,d) +textExtents (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + fi (rect_y rl) + return (ascent, descent) +#ifdef XFT +textExtents (Xft xftfonts) _ = do + ascent <- fi `fmap` xft_ascent' xftfonts + descent <- fi `fmap` xft_descent' xftfonts + return (ascent, descent) +#endif + +printString :: Display -> Drawable -> XFont -> GC -> String -> String + -> Position -> Position -> String -> Int -> IO () +printString d p (Core fs) gc fc bc x y s a = do + setFont d gc $ fontFromFontStruct fs + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + when (a == 255) (setBackground d gc bc') + drawImageString d p gc x y s + +printString d p (Utf8 fs) gc fc bc x y s a = + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + when (a == 255) (setBackground d gc bc') + io $ wcDrawImageString d p fs gc x y s + +#ifdef XFT +printString dpy drw fs@(Xft fonts) _ fc bc x y s al = + withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do + when (al == 255) $ do + (a,d) <- textExtents fs s + gi <- xftTxtExtents' dpy fonts s + drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) + drawXftString' draw fc' fonts (toInteger x) (toInteger y) s +#endif + + +-- | Creates a window with the attribute override_redirect set to True. +-- Windows Managers should not touch this kind of windows. +newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window +newWindow dpy scr rw (Rectangle x y w h) o = do + let visual = defaultVisualOfScreen scr + attrmask = if o then cWOverrideRedirect else 0 + allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes o + createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) + inputOutput visual attrmask attributes +-- | A version of nextEvent that does not block in foreign calls. +nextEvent' :: Display -> XEventPtr -> IO () +nextEvent' d p = do + pend <- pending d + if pend /= 0 + then nextEvent d p + else do + threadWaitRead (Fd fd) + nextEvent' d p + where + fd = connectionNumber d + +io :: MonadIO m => IO a -> m a +io = liftIO + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +#if __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8) +#include <locale.h> +foreign import ccall unsafe "locale.h setlocale" + setlocale :: CInt -> CString -> IO CString + +setupLocale :: IO () +setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return () +# else +setupLocale :: IO () +setupLocale = return () +#endif |