diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Main +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- The main module of Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Main (main) where + +import Xmobar + +main :: IO () +main = xmobarMain diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,8 +1,29 @@ +## Version 0.29 (December, 2018) + +_New features_ + + - New `Alsa` monitor for volume display that doesn't use polling, by + Daniel Schüssler. + - `ThermalZone` retries reading missing files, thanks to Reed Koser. + - `TopProc` ignores kernel threads (see also [issue #369]). + - `Wireless` simple autodetection of wirless interface name (if set + to ""). + - Experimental support for using xmobar as a library, so that + configurations are in fact Haskell programs a la Xmonad (beta + stage, with help from Pavan Rikhi). Traditional config files are + still (and will continue to be) supported. + +_Bug fixes_ + + - Correctly parsing configuration options `mwClass` and `wmName`. + +[issue #369]: https://github.com/jaor/xmobar/issues/369 + ## Version 0.28.1 (October, 2018) Dependencies updated to work with GHC 8.6, avoiding [issue #354]. -[issue #354]: https://github.com/jaor/xmobar/issues/356 +[issue #354]: https://github.com/jaor/xmobar/issues/354 ## Version 0.28 (August, 2018) diff --git a/examples/Plugins/HelloWorld.hs b/examples/Plugins/HelloWorld.hs new file mode 100644 --- /dev/null +++ b/examples/Plugins/HelloWorld.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.HelloWorld +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin example for Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.HelloWorld where + +import Xmobar.Plugins + +data HelloWorld = HelloWorld + deriving (Read, Show) + +instance Exec HelloWorld where + alias HelloWorld = "helloWorld" + run HelloWorld = return "Hello World!!" diff --git a/examples/Plugins/helloworld.config b/examples/Plugins/helloworld.config new file mode 100644 --- /dev/null +++ b/examples/Plugins/helloworld.config @@ -0,0 +1,12 @@ +Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , bgColor = "#000000" + , fgColor = "#BFBFBF" + , position = TopW C 90 + , commands = [ Run Cpu [] 10 + , Run Weather "LIPB" [] 36000 + , Run HelloWorld + ] + , sepChar = "%" + , alignSep = "}{" + , template = "%cpu% } %helloWorld% { %LIPB% | %date%" + } diff --git a/examples/padding-icon.sh b/examples/padding-icon.sh new file mode 100644 --- /dev/null +++ b/examples/padding-icon.sh @@ -0,0 +1,56 @@ +#!/bin/bash + +# Detects the width of running window with name given as first +# argument (xprop name '$1') and creates an XPM icon of that width, +# 1px height, and transparent. Outputs an -tag for use in +# xmobar to display the generated XPM icon. +# +# Run script from xmobar and trayer: +# `Run Com "/where/ever/padding-icon.sh" ["panel"] "trayerpad" 10` +# and use `%trayerpad%` in your template. +# or, if you're using for instance stalonetray: +# `Run Com "/where/ever/padding-icon.sh" ["stalonetray"] "tray" 10` + +# Very heavily based on Jonas Camillus Jeppensen code +# https://github.com/jaor/xmobar/issues/239#issuecomment-233206552 + +# Function to create a transparent Wx1 px XPM icon +create_xpm_icon () { +timestamp=$(date) +pixels=$(for i in `seq $1`; do echo -n "."; done) + +cat << EOF > "$2" +/* XPM * +static char * trayer_pad_xpm[] = { +/* This XPM icon is used for padding in xmobar to */ +/* leave room for trayer-srg. It is dynamically */ +/* updated by by trayer-pad-icon.sh which is run */ +/* by xmobar. */ +/* Created: ${timestamp} */ +/* */ +"$1 1 1 1", +/* Colors (none: transparent) */ +". c none", +/* Pixels */ +"$pixels" +}; +EOF +} + +# panel window name +pname=${1:-panel} + +# Width of the trayer window +width=$(xprop -name $pname | grep 'program specified minimum size' | cut -d ' ' -f 5) + +# Icon file name +iconfile="/tmp/$pname-padding-${width:-0}px.xpm" + +# If the desired icon does not exist create it +if [ ! -f $iconfile ] +then + create_xpm_icon $width $iconfile +fi + +# Output the icon tag for xmobar +echo "" diff --git a/examples/xmobar.config b/examples/xmobar.config new file mode 100644 --- /dev/null +++ b/examples/xmobar.config @@ -0,0 +1,38 @@ +Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , additionalFonts = [] + , borderColor = "black" + , border = TopB + , bgColor = "black" + , fgColor = "grey" + , alpha = 255 + , position = Top + , textOffset = -1 + , iconOffset = -1 + , lowerOnStart = True + , pickBroadest = False + , persistent = False + , hideOnStart = False + , iconRoot = "." + , allDesktops = True + , overrideRedirect = True + , commands = [ Run Weather "EGPF" ["-t",": C", + "-L","18","-H","25", + "--normal","green", + "--high","red", + "--low","lightblue"] 36000 + , Run Network "eth0" ["-L","0","-H","32", + "--normal","green","--high","red"] 10 + , Run Network "eth1" ["-L","0","-H","32", + "--normal","green","--high","red"] 10 + , Run Cpu ["-L","3","-H","50", + "--normal","green","--high","red"] 10 + , Run Memory ["-t","Mem: %"] 10 + , Run Swap [] 10 + , Run Com "uname" ["-s","-r"] "" 36000 + , Run Date "%a %b %_d %Y %H:%M:%S" "date" 10 + ] + , sepChar = "%" + , alignSep = "}{" + , template = "%cpu% | %memory% * %swap% | %eth0% - %eth1% }\ + \{ %date%| %EGPF% | %uname%" + } diff --git a/examples/xmonadpropwrite.hs b/examples/xmonadpropwrite.hs new file mode 100644 --- /dev/null +++ b/examples/xmonadpropwrite.hs @@ -0,0 +1,41 @@ +-- Copyright Spencer Janssen +-- Tomas Janousek +-- BSD3 (see LICENSE) +-- +-- Reads from standard input and writes to an X propery on root window. +-- To be used with XPropertyLog: +-- Add it to commands: +-- Run XPropertyLog "_XMONAD_LOG_CUSTOM" +-- Add it to the template: +-- template = "... %_XMONAD_LOG_CUSTOM% ..." +-- Run: +-- $ blah blah | xmonadpropwrite _XMONAD_LOG_CUSTOM + +import Control.Monad +import Graphics.X11 +import Graphics.X11.Xlib.Extras +import qualified Data.ByteString as B +import Foreign.C (CChar) +import System.IO +import System.Environment + +main = do + atom <- flip fmap getArgs $ \args -> case args of + [a] -> a + _ -> "_XMONAD_LOG" + + d <- openDisplay "" + xlog <- internAtom d atom False + ustring <- internAtom d "UTF8_STRING" False + + root <- rootWindow d (defaultScreen d) + + forever $ do + msg <- B.getLine + changeProperty8 d root xlog ustring propModeReplace (encodeCChar msg) + sync d True + + return () + +encodeCChar :: B.ByteString -> [CChar] +encodeCChar = map fromIntegral . B.unpack diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -3,31 +3,25 @@ # About -xmobar is a minimalistic, mostly text based, status bar. It was -originally designed and implemented by Andrea Rossato to work with -[xmonad], but it's actually usable with any window-manager. +Xmobar is a minimalistic status bar. It was originally designed and +implemented by Andrea Rossato to work with [xmonad], but it is +actually usable with any window manager. -xmobar was inspired by the [Ion3] status bar, and supports similar +Xmobar was inspired by the [Ion3] status bar, and supports similar features, like dynamic color management, icons, output templates, and extensibility through plugins. -[This screenshot] shows xmobar running under [sawfish], with -antialiased fonts. And [this one] is my desktop with [xmonad] and two -instances of xmobar. +[This screenshot](doc/xmobar-sawfish.png) shows xmobar running under +[sawfish], and [this one](doc/xmobar-xmonad.png) is a desktop with +[xmonad] and two instances of xmobar. [xmonad]: http://xmonad.org [Ion3]: http://tuomov.iki.fi/software/ -[This screenshot]: http://projects.haskell.org/xmobar/xmobar-sawfish.png -[this one]: http://projects.haskell.org/xmobar/xmobar-xmonad.png # Bug Reports -To submit bug reports you can use the [bug tracker over at Github]. - -Note: the old bug tracker at Google code is deprecated. Please use -Github's for new bugs. - -[bug tracker over at Github]: https://github.com/jaor/xmobar/issues +To submit bug reports you can use the [bug tracker over at +Github](https://github.com/jaor/xmobar/issues). # Installation @@ -75,7 +69,7 @@ There is also a barebones `stack.yaml` file that will allow you to build the xmobar executable with stances of the form: - stack build --flag xmobar:all_extensions + stack install --flag xmobar:all_extensions ## Optional features @@ -173,9 +167,9 @@ ## Quick Start -See [samples/xmobar.config] for an example. +See [examples/xmobar.config] for an example. -[samples/xmobar.config]: http://github.com/jaor/xmobar/raw/master/samples/xmobar.config +[examples/xmobar.config]: http://github.com/jaor/xmobar/raw/master/examples/xmobar.config For the output template: @@ -342,6 +336,16 @@ status bar or xmobar's `StdinReader`. See [i3status manual] for further details. +### Dynamically sizing xmobar + +See [this idea] by Jonas Camillus Jeppensen for a way of adapting +dynamically xmobar's size and run it alongside a system tray widget +such as trayer or stalonetray (although the idea is not limited to +trays, really). For your convenience, there is a version of Jonas' +script in [examples/padding-icon.sh](./examples/padding-icon.sh). + +[this idea]: https://github.com/jaor/xmobar/issues/239#issuecomment-233206552 + ## Command Line Options xmobar can be either configured with a configuration file or with @@ -360,27 +364,30 @@ Options: -h, -? --help This help -V --version Show version information - -f font name --font=font name The font name + -v --verbose Emit verbose debugging messages + -r --recompile Force recompilation (for Haskell FILE) + -f font name --font=font name Font name -w class --wmclass=class X11 WM_CLASS property -n name --wmname=name X11 WM_NAME property - -B bg color --bgcolor=bg color The background color. Default black - -F fg color --fgcolor=fg color The foreground color. Default grey - -A alpha --alpha=alpha The transparency: 0 is transparent, 255 (the default) is opaque + -B bg color --bgcolor=bg color Background color. Default black + -F fg color --fgcolor=fg color Foreground color. Default grey + -A alpha --alpha=alpha Transparency: 0 is transparent + and 255 (the default) is opaque -o --top Place xmobar at the top of the screen -b --bottom Place xmobar at the bottom of the screen -p --position=position Specify position, same as in config file -d --dock Try to start xmobar as a dock -a alignsep --alignsep=alignsep Separators for left, center and right text alignment. Default: '}{' - -s char --sepchar=char The character used to separate commands in + -s char --sepchar=char Character used to separate commands in the output template. Default '%' - -t template --template=template The output template + -t template --template=template Output template -i path --iconroot=path Default directory for icon pattern files - -c commands --commands=commands The list of commands to be executed + -c commands --commands=commands List of commands to be executed -C command --add-command=command Add to the list of commands to be executed -x screen --screen=screen On which X screen number to start - Mail bug reports and suggestions to + Mail bug reports and suggestions to ## The DBus Interface @@ -769,8 +776,9 @@ ### `Wireless Interface Args RefreshRate` +- If set to "", the interface is looked up in /proc/net/wireless. - Aliases to the interface name with the suffix "wi": thus, `Wireless - "wlan0" []` can be used as `%wlan0wi%` + "wlan0" []` can be used as `%wlan0wi%`, and `Wireless "" []` as `%wi%`. - Args: default monitor arguments, plus: - `--quality-icon-pattern`: dynamic string for connection quality in `qualityipat`. - Variables that can be used with the `-t`/`--template` argument: @@ -1072,6 +1080,21 @@ system. In addition, to activate this plugin you must pass `--flags="with_alsa"` during compilation. +### `Alsa Mixer Element Args` + +Like [Volume](#volume-mixer-element-args-refreshrate), but with the following differences: +- Uses event-based refreshing via `alsactl monitor` instead of polling, so it will refresh + instantly when there's a volume change, and won't use CPU until a change happens. +- Aliases to `alsa:` followed by the mixer name and element name separated by a colon. Thus, + `Alsa "default" "Master" []` can be used as `%alsa:default:Master%`. +- Additional options (after the `--`): + - `--alsactl=/path/to/alsactl` + - If this option is not specified, `alsactl` will be sought in your `PATH` + first, and failing that, at `/usr/sbin/alsactl` (this is its location on + Debian systems. `alsactl monitor` works as a non-root user despite living + in `/usr/sbin`.). +- `stdbuf` (from coreutils) must be (and most probably already is) in your `PATH`. + ### `MPD Args RefreshRate` - This monitor will only be compiled if you ask for it using the @@ -1176,11 +1199,11 @@ - Aliases to `PropName` - Reads the X property named by `PropName` (a string) and displays its - value. The [samples/xmonadpropwrite.hs script] in xmobar's + value. The [examples/xmonadpropwrite.hs script] in xmobar's distribution can be used to set the given property from the output of any other program or script. -[samples/xmonadpropwrite.hs script]: https://github.com/jaor/xmobar/raw/master/samples/xmonadpropwrite.hs +[examples/xmonadpropwrite.hs script]: https://github.com/jaor/xmobar/raw/master/examples/xmonadpropwrite.hs ### `UnsafeXPropertyLog PropName` @@ -1394,10 +1417,10 @@ your xmobar. Sending some status information to `"/tmp/xmobar_status"` will reveal xmonad for 1.5 seconds and temporarily overwrite the window titles. -- Take a look at [samples/status.sh] +- Take a look at [examples/status.sh] - Expands environment variables for the pipe path -[samples/status.sh]: http://github.com/jaor/xmobar/raw/master/samples/status.sh +[examples/status.sh]: http://github.com/jaor/xmobar/raw/master/examples/status.sh **`XMonadLog`** @@ -1491,7 +1514,7 @@ This requires importing your plugin into `Config.hs` and adding your type to the type list in the type signature of `Config.runnableTypes`. -For a very basic example see `samples/Plugins/HelloWorld.hs` or the +For a very basic example see `examples/Plugins/HelloWorld.hs` or the other plugins that are distributed with xmobar. ## Installing/Removing a Plugin @@ -1558,16 +1581,16 @@ Patrick Chilton, Antoine Eiche, Nathaniel Wesley Filardo, John Goerzen, Reto Hablützel, Juraj Hercek, Tomáš Janoušek, Ada Joule, Spencer Janssen, Roman Joost, Jochen Keil, Lennart Kolmodin, Krzysztof -Kosciuszkiewicz, Dmitry Kurochkin, Todd Lunter, Robert J. Macomber, -Dmitry Malikov, David McLean, Marcin Mikołajczyk, Dino Morelli, Tony -Morris, Eric Mrak, Thiago Negri, Edward O'Callaghan, Svein Ove, Martin -Perner, Jens Petersen, Alexander Polakov, Petr Rockai, Andrew -Sackville-West, Markus Scherer, Olivier Schneider, Alexander Shabalin, -Valentin Shirokov, Peter Simons, Alexander Solovyov, Will Song, John -Soros, Travis Staton, Artem Tarasov, Samuli Thomasson, Edward -Tjörnhammar, Sergei Trofimovich, Thomas Tuegel, Jan Vornberger, Anton -Vorontsov, Daniel Wagner, Zev Weiss, Phil Xiaojun Hu, Edward Z. Yang -and Norbert Zeh. +Kosciuszkiewicz, Dmitry Kurochkin, Todd Lunter, Vanessa McHale, Robert +J. Macomber, Dmitry Malikov, David McLean, Marcin Mikołajczyk, Dino +Morelli, Tony Morris, Eric Mrak, Thiago Negri, Edward O'Callaghan, +Svein Ove, Martin Perner, Jens Petersen, Alexander Polakov, Pavan +Rikhi, Petr Rockai, Andrew Sackville-West, Markus Scherer, Daniel +Schüssler, Olivier Schneider, Alexander Shabalin, Valentin Shirokov, +Peter Simons, Alexander Solovyov, Will Song, John Soros, Travis +Staton, Artem Tarasov, Samuli Thomasson, Edward Tjörnhammar, Sergei +Trofimovich, Thomas Tuegel, Jan Vornberger, Anton Vorontsov, Daniel +Wagner, Zev Weiss, Phil Xiaojun Hu, Edward Z. Yang and Norbert Zeh. [jao]: http://jao.io [incorporates patches]: http://www.ohloh.net/p/xmobar/contributors diff --git a/samples/Plugins/HelloWorld.hs b/samples/Plugins/HelloWorld.hs deleted file mode 100644 --- a/samples/Plugins/HelloWorld.hs +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.HelloWorld --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin example for Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Plugins.HelloWorld where - -import Plugins - -data HelloWorld = HelloWorld - deriving (Read, Show) - -instance Exec HelloWorld where - alias HelloWorld = "helloWorld" - run HelloWorld = return "Hello World!!" diff --git a/samples/Plugins/helloworld.config b/samples/Plugins/helloworld.config deleted file mode 100644 --- a/samples/Plugins/helloworld.config +++ /dev/null @@ -1,12 +0,0 @@ -Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , bgColor = "#000000" - , fgColor = "#BFBFBF" - , position = TopW C 90 - , commands = [ Run Cpu [] 10 - , Run Weather "LIPB" [] 36000 - , Run HelloWorld - ] - , sepChar = "%" - , alignSep = "}{" - , template = "%cpu% } %helloWorld% { %LIPB% | %date%" - } diff --git a/samples/xmobar.config b/samples/xmobar.config deleted file mode 100644 --- a/samples/xmobar.config +++ /dev/null @@ -1,38 +0,0 @@ -Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , additionalFonts = [] - , borderColor = "black" - , border = TopB - , bgColor = "black" - , fgColor = "grey" - , alpha = 255 - , position = Top - , textOffset = -1 - , iconOffset = -1 - , lowerOnStart = True - , pickBroadest = False - , persistent = False - , hideOnStart = False - , iconRoot = "." - , allDesktops = True - , overrideRedirect = True - , commands = [ Run Weather "EGPF" ["-t",": C", - "-L","18","-H","25", - "--normal","green", - "--high","red", - "--low","lightblue"] 36000 - , Run Network "eth0" ["-L","0","-H","32", - "--normal","green","--high","red"] 10 - , Run Network "eth1" ["-L","0","-H","32", - "--normal","green","--high","red"] 10 - , Run Cpu ["-L","3","-H","50", - "--normal","green","--high","red"] 10 - , Run Memory ["-t","Mem: %"] 10 - , Run Swap [] 10 - , Run Com "uname" ["-s","-r"] "" 36000 - , Run Date "%a %b %_d %Y %H:%M:%S" "date" 10 - ] - , sepChar = "%" - , alignSep = "}{" - , template = "%cpu% | %memory% * %swap% | %eth0% - %eth1% }\ - \{ %date%| %EGPF% | %uname%" - } diff --git a/samples/xmonadpropwrite.hs b/samples/xmonadpropwrite.hs deleted file mode 100644 --- a/samples/xmonadpropwrite.hs +++ /dev/null @@ -1,41 +0,0 @@ --- Copyright Spencer Janssen --- Tomas Janousek --- BSD3 (see LICENSE) --- --- Reads from standard input and writes to an X propery on root window. --- To be used with XPropertyLog: --- Add it to commands: --- Run XPropertyLog "_XMONAD_LOG_CUSTOM" --- Add it to the template: --- template = "... %_XMONAD_LOG_CUSTOM% ..." --- Run: --- $ blah blah | xmonadpropwrite _XMONAD_LOG_CUSTOM - -import Control.Monad -import Graphics.X11 -import Graphics.X11.Xlib.Extras -import qualified Data.ByteString as B -import Foreign.C (CChar) -import System.IO -import System.Environment - -main = do - atom <- flip fmap getArgs $ \args -> case args of - [a] -> a - _ -> "_XMONAD_LOG" - - d <- openDisplay "" - xlog <- internAtom d atom False - ustring <- internAtom d "UTF8_STRING" False - - root <- rootWindow d (defaultScreen d) - - forever $ do - msg <- B.getLine - changeProperty8 d root xlog ustring propModeReplace (encodeCChar msg) - sync d True - - return () - -encodeCChar :: B.ByteString -> [CChar] -encodeCChar = map fromIntegral . B.unpack diff --git a/src/Actions.hs b/src/Actions.hs deleted file mode 100644 --- a/src/Actions.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Actions --- Copyright : (c) Alexander Polakov --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module 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 "`]*)`?( +button=[12345]+)?>(.+)" diff --git a/src/Bitmap.hs b/src/Bitmap.hs deleted file mode 100644 --- a/src/Bitmap.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Bitmap --- Copyright : (C) 2013, 2015, 2017, 2018 Alexander Polakov --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module 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 ColorCache -import Parsers (Widget(..)) -import Actions (Action) - -#ifdef XPM -import 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/ColorCache.hs b/src/ColorCache.hs deleted file mode 100644 --- a/src/ColorCache.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# 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 ColorCache(withColors, withDrawingColors) where - -import MinXft - -#else -module 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/Commands.hs b/src/Commands.hs deleted file mode 100644 --- a/src/Commands.hs +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Commands --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- 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 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 Signal -import 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/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Config --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The configuration module of Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Config - ( -- * Configuration - -- $config - Config (..) - , XPosition (..), Align (..), Border(..) - , defaultConfig - , runnableTypes - ) where - - -import Commands -import {-# SOURCE #-} Runnable -import Plugins.Monitors -import Plugins.Date -import Plugins.PipeReader -import Plugins.BufferedPipeReader -import Plugins.MarqueePipeReader -import Plugins.CommandReader -import Plugins.StdinReader -import Plugins.XMonadLog -import Plugins.EWMH -import Plugins.Kbd -import Plugins.Locks - -import Plugins.Mail -import Plugins.MBox - -import Plugins.DateZone - --- $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% }{ " ++ - "%uname% * %theDate%" - } - - --- | 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 :*: Mail :*: MBox :*: - DateZone :*: MarqueePipeReader :*: () -runnableTypes = undefined diff --git a/src/Environment.hs b/src/Environment.hs deleted file mode 100644 --- a/src/Environment.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMobar.Environment --- Copyright : (c) William Song --- License : BSD-style (see LICENSE) --- --- Maintainer : Will Song --- Stability : stable --- Portability : portable --- --- A function to expand environment variables in strings --- ------------------------------------------------------------------------------ -module 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/IPC/DBus.hs b/src/IPC/DBus.hs deleted file mode 100644 --- a/src/IPC/DBus.hs +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : DBus --- Copyright : (c) Jochen Keil --- License : BSD-style (see LICENSE) --- --- Maintainer : Jochen Keil --- Stability : unstable --- Portability : unportable --- --- DBus IPC module for Xmobar --- ------------------------------------------------------------------------------ - -module IPC.DBus (runIPC) where - -import DBus -import DBus.Client hiding (interfaceName) -import qualified DBus.Client as DC -import Control.Monad (when) -import Control.Concurrent.STM -import Control.Exception (handle) -import System.IO (stderr, hPutStrLn) -import Control.Monad.IO.Class (liftIO) - -import 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 $ do - when ( methodCallMember mc == sendSignalName ) - $ mapM_ (sendSignal . fromVariant) (methodCallBody mc) - return ( ReplyReturn [] ) - - sendSignal :: Maybe SignalType -> IO () - sendSignal = maybe (return ()) (atomically . putTMVar mvst) diff --git a/src/Localize.hsc b/src/Localize.hsc deleted file mode 100644 --- a/src/Localize.hsc +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Localize --- Copyright : (C) 2011 Martin Perner --- License : BSD-style (see LICENSE) --- --- Maintainer : Martin Perner --- Stability : unstable --- Portability : unportable --- --- This module provides an interface to locale information e.g. for DateL --- ------------------------------------------------------------------------------ - -module 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 -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 -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/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Main --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The main module of Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Main ( -- * Main Stuff - -- $main - main - , readConfig - , readDefaultConfig - ) where - -import Xmobar -import Parsers -import Config -import XUtil - -import Data.List (intercalate) -import qualified Data.Map as Map - -import Paths_xmobar (version) -import Data.Version (showVersion) -import Graphics.X11.Xlib -import System.Console.GetOpt -import System.Directory (getHomeDirectory) -import System.Exit -import System.Environment -import System.FilePath (()) -import System.Posix.Files -import Control.Monad (unless) -import Text.Read (readMaybe) - -import Signal (setupSignalHandler) - --- $main - --- | The main entry point -main :: IO () -main = do - initThreads - d <- openDisplay "" - args <- getArgs - (o,file) <- getOpts args - (c,defaultings) <- case file of - [cfgfile] -> readConfig cfgfile - _ -> readDefaultConfig - - unless (null defaultings) $ putStrLn $ - "Fields missing from config defaulted: " ++ intercalate "," defaultings - - conf <- doOpts c o - fs <- initFont d (font conf) - fl <- mapM (initFont d) (additionalFonts conf) - cls <- mapM (parseTemplate conf) (splitTemplate conf) - sig <- setupSignalHandler - vars <- mapM (mapM $ startCommand sig) cls - (r,w) <- createWin d fs conf - let ic = Map.empty - to = textOffset conf - ts = textOffsets conf ++ replicate (length fl) (-1) - startLoop (XConf d r w (fs:fl) (to:ts) ic conf) sig vars - --- | Splits the template in its parts -splitTemplate :: Config -> [String] -splitTemplate conf = - case break (==l) t of - (le,_:re) -> case break (==r) re of - (ce,_:ri) -> [le, ce, ri] - _ -> def - _ -> def - where [l, r] = alignSep - (if length (alignSep conf) == 2 then conf else defaultConfig) - t = template conf - def = [t, "", ""] - - --- | Reads the configuration files or quits with an error -readConfig :: FilePath -> IO (Config,[String]) -readConfig f = do - file <- io $ fileExist f - s <- io $ if file then readFileSafe f else error $ - f ++ ": file not found!\n" ++ usage - either (\err -> error $ f ++ - ": configuration file contains errors at:\n" ++ show err) - return $ parseConfig s - -xdgConfigDir :: IO String -xdgConfigDir = do env <- getEnvironment - case lookup "XDG_CONFIG_HOME" env of - Just val -> return val - Nothing -> fmap ( ".config") getHomeDirectory - -xmobarConfigDir :: IO FilePath -xmobarConfigDir = fmap ( "xmobar") xdgConfigDir - -getXdgConfigFile :: IO FilePath -getXdgConfigFile = fmap ( "xmobarrc") xmobarConfigDir - --- | Read default configuration file or load the default config -readDefaultConfig :: IO (Config,[String]) -readDefaultConfig = do - xdgConfigFile <- getXdgConfigFile - xdgConfigFileExists <- io $ fileExist xdgConfigFile - home <- io $ getEnv "HOME" - let defaultConfigFile = home ++ "/.xmobarrc" - defaultConfigFileExists <- io $ fileExist defaultConfigFile - if xdgConfigFileExists - then readConfig xdgConfigFile - else if defaultConfigFileExists - then readConfig defaultConfigFile - else return (defaultConfig,[]) - -data Opts = Help - | Version - | Font String - | BgColor String - | FgColor String - | Alpha String - | T - | B - | D - | AlignSep String - | Commands String - | AddCommand String - | SepChar String - | Template String - | OnScr String - | IconRoot String - | Position String - | WmClass String - | WmName String - deriving Show - -options :: [OptDescr Opts] -options = - [ Option "h?" ["help"] (NoArg Help) "This help" - , Option "V" ["version"] (NoArg Version) "Show version information" - , Option "f" ["font"] (ReqArg Font "font name") "The font name" - , Option "w" ["wmclass"] (ReqArg WmClass "class") "X11 WM_CLASS property" - , Option "n" ["wmname"] (ReqArg WmName "name") "X11 WM_NAME property" - , Option "B" ["bgcolor"] (ReqArg BgColor "bg color" ) - "The background color. Default black" - , Option "F" ["fgcolor"] (ReqArg FgColor "fg color") - "The foreground color. Default grey" - , Option "i" ["iconroot"] (ReqArg IconRoot "path") - "Root directory for icon pattern paths. Default '.'" - , Option "A" ["alpha"] (ReqArg Alpha "alpha") - "The transparency: 0 is transparent, 255 is opaque. Default: 255" - , Option "o" ["top"] (NoArg T) "Place xmobar at the top of the screen" - , Option "b" ["bottom"] (NoArg B) - "Place xmobar at the bottom of the screen" - , Option "d" ["dock"] (NoArg D) - "Don't override redirect from WM and function as a dock" - , Option "a" ["alignsep"] (ReqArg AlignSep "alignsep") - "Separators for left, center and right text\nalignment. Default: '}{'" - , Option "s" ["sepchar"] (ReqArg SepChar "char") - ("The character used to separate commands in" ++ - "\nthe output template. Default '%'") - , Option "t" ["template"] (ReqArg Template "template") - "The output template" - , Option "c" ["commands"] (ReqArg Commands "commands") - "The list of commands to be executed" - , Option "C" ["add-command"] (ReqArg AddCommand "command") - "Add to the list of commands to be executed" - , Option "x" ["screen"] (ReqArg OnScr "screen") - "On which X screen number to start" - , Option "p" ["position"] (ReqArg Position "position") - "Specify position of xmobar. Same syntax as in config file" - ] - -getOpts :: [String] -> IO ([Opts], [String]) -getOpts argv = - case getOpt Permute options argv of - (o,n,[]) -> return (o,n) - (_,_,errs) -> error (concat errs ++ usage) - -usage :: String -usage = usageInfo header options ++ footer - where header = "Usage: xmobar [OPTION...] [FILE]\nOptions:" - footer = "\nMail bug reports and suggestions to " ++ mail ++ "\n" - -info :: String -info = "xmobar " ++ showVersion version - ++ "\n (C) 2007 - 2010 Andrea Rossato " - ++ "\n (C) 2010 - 2018 Jose A Ortega Ruiz\n " - ++ mail ++ "\n" ++ license - -mail :: String -mail = "" - -license :: String -license = "\nThis program is distributed in the hope that it will be useful," ++ - "\nbut WITHOUT ANY WARRANTY; without even the implied warranty of" ++ - "\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." ++ - "\nSee the License for more details." - -doOpts :: Config -> [Opts] -> IO Config -doOpts conf [] = - return (conf {lowerOnStart = lowerOnStart conf && overrideRedirect conf}) -doOpts conf (o:oo) = - case o of - Help -> putStr usage >> exitSuccess - Version -> putStrLn info >> exitSuccess - Font s -> doOpts' (conf {font = s}) - WmClass s -> doOpts' (conf {wmClass = s}) - WmName s -> doOpts' (conf {wmName = s}) - BgColor s -> doOpts' (conf {bgColor = s}) - FgColor s -> doOpts' (conf {fgColor = s}) - Alpha n -> doOpts' (conf {alpha = read n}) - T -> doOpts' (conf {position = Top}) - B -> doOpts' (conf {position = Bottom}) - D -> doOpts' (conf {overrideRedirect = False}) - AlignSep s -> doOpts' (conf {alignSep = s}) - SepChar s -> doOpts' (conf {sepChar = s}) - Template s -> doOpts' (conf {template = s}) - IconRoot s -> doOpts' (conf {iconRoot = s}) - OnScr n -> doOpts' (conf {position = OnScreen (read n) $ position conf}) - Commands s -> case readCom 'c' s of - Right x -> doOpts' (conf {commands = x}) - Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) - AddCommand s -> case readCom 'C' s of - Right x -> doOpts' (conf {commands = commands conf ++ x}) - Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) - Position s -> readPosition s - where readCom c str = - case readStr str of - [x] -> Right x - _ -> Left ("xmobar: cannot read list of commands " ++ - "specified with the -" ++ c:" option\n") - readStr str = [x | (x,t) <- reads str, ("","") <- lex t] - doOpts' opts = doOpts opts oo - readPosition string = - case readMaybe string of - Just x -> doOpts' (conf { position = x }) - Nothing -> do - putStrLn "Can't parse position option, ignoring" - doOpts' conf diff --git a/src/MinXft.hsc b/src/MinXft.hsc deleted file mode 100644 --- a/src/MinXft.hsc +++ /dev/null @@ -1,333 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: MinXft --- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz --- (c) Clemens Fruhwirth 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 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 - --- 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 - -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/Parsers.hs b/src/Parsers.hs deleted file mode 100644 --- a/src/Parsers.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- Parsers needed for Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Parsers - ( parseString - , parseTemplate - , parseConfig - , Widget(..) - ) where - -import Config -import Runnable -import Commands -import 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 "". -rawParser :: ColorString - -> FontIndex - -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -rawParser c f a = do - string " 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 "") (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 "")] - 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 "") - 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 "") colors - s <- manyTill (allParsers c f a) (try $ string "") - 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 "") colors - s <- manyTill (allParsers c (read f) a) (try $ string "") - 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 "windowName" - 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/Plugins.hs b/src/Plugins.hs deleted file mode 100644 --- a/src/Plugins.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Plugins --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- This module exports the API for plugins. --- --- Have a look at Plugins\/HelloWorld.hs --- ------------------------------------------------------------------------------ - -module Plugins - ( Exec (..) - , tenthSeconds - , readFileSafe - , hGetLineSafe - ) where - -import Commands -import XUtil diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs deleted file mode 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.BufferedPipeReader --- Copyright : (c) Jochen Keil --- License : BSD-style (see LICENSE) --- --- Maintainer : Jochen Keil --- Stability : unstable --- Portability : unportable --- --- A plugin for reading (temporarily) from named pipes with reset --- ------------------------------------------------------------------------------ - -module 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 Environment -import Plugins -import 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/Plugins/CommandReader.hs b/src/Plugins/CommandReader.hs deleted file mode 100644 --- a/src/Plugins/CommandReader.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.CommandReader --- Copyright : (c) John Goerzen --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from external commands --- note: stderr is lost here --- ------------------------------------------------------------------------------ - -module Plugins.CommandReader where - -import System.IO -import 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/Plugins/Date.hs b/src/Plugins/Date.hs deleted file mode 100644 --- a/src/Plugins/Date.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Date --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A date plugin for Xmobar --- --- Usage example: in template put --- --- > Run Date "%a %b %_d %Y %H:%M:%S" "Mydate" 10 --- ------------------------------------------------------------------------------ - -module Plugins.Date (Date(..)) where - -import 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/Plugins/DateZone.hs b/src/Plugins/DateZone.hs deleted file mode 100644 --- a/src/Plugins/DateZone.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DoAndIfThenElse #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.DateZone --- Copyright : (c) Martin Perner --- License : BSD-style (see LICENSE) --- --- Maintainer : Martin Perner --- 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 Plugins.DateZone (DateZone(..)) where - -import Plugins - - -#ifdef DATEZONE -import Control.Concurrent.STM - -import System.IO.Unsafe - -import 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 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/Plugins/EWMH.hs b/src/Plugins/EWMH.hs deleted file mode 100644 --- a/src/Plugins/EWMH.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# 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 --- Stability : unstable --- Portability : unportable --- --- An experimental plugin to display EWMH pager information --- ------------------------------------------------------------------------------ - -module 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 Plugins -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar, CLong) -import 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 ["", x, ""] -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/Plugins/Kbd.hsc b/src/Plugins/Kbd.hsc deleted file mode 100644 --- a/src/Plugins/Kbd.hsc +++ /dev/null @@ -1,404 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Kbd --- Copyright : (c) Martin Perner --- License : BSD-style (see LICENSE) --- --- Maintainer : Martin Perner --- Stability : unstable --- Portability : unportable --- --- A keyboard layout indicator for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Kbd where - -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras -import Foreign -import Foreign.C.Types -import Foreign.C.String -import Plugins -import Control.Monad (forever) -import XUtil (nextEvent') -import Data.List (isPrefixOf, findIndex) -import Data.Maybe (fromJust) - -#include -#include -#include - --- --- 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/Plugins/Locks.hs b/src/Plugins/Locks.hs deleted file mode 100644 --- a/src/Plugins/Locks.hs +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Locks --- Copyright : (c) Patrick Chilton --- License : BSD-style (see LICENSE) --- --- Maintainer : Patrick Chilton --- Stability : unstable --- Portability : unportable --- --- A plugin that displays the status of the lock keys. --- ------------------------------------------------------------------------------ - -module Plugins.Locks where - -import Graphics.X11 -import Data.List -import Data.Bits -import Control.Monad -import Graphics.X11.Xlib.Extras -import Plugins -import Plugins.Kbd -import XUtil (nextEvent') - -data Locks = Locks - deriving (Read, Show) - -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/Plugins/MBox.hs b/src/Plugins/MBox.hs deleted file mode 100644 --- a/src/Plugins/MBox.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.MBox --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin for checking mail in mbox files. --- ------------------------------------------------------------------------------ - -module Plugins.MBox (MBox(..)) where - -import Prelude -import Plugins -#ifdef INOTIFY -import 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 "" ++ msg ++ "" - 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/Plugins/Mail.hs b/src/Plugins/Mail.hs deleted file mode 100644 --- a/src/Plugins/Mail.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Mail --- Copyright : (c) Spencer Janssen --- License : BSD-style (see LICENSE) --- --- Maintainer : Spencer Janssen --- Stability : unstable --- Portability : unportable --- --- A plugin for checking mail. --- ------------------------------------------------------------------------------ - -module Plugins.Mail where - -import Plugins -#ifdef INOTIFY -import 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/Plugins/MarqueePipeReader.hs b/src/Plugins/MarqueePipeReader.hs deleted file mode 100644 --- a/src/Plugins/MarqueePipeReader.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.MarqueePipeReader --- Copyright : (c) Reto Habluetzel --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from named pipes for long texts with marquee --- ------------------------------------------------------------------------------ - -module Plugins.MarqueePipeReader where - -import System.IO (openFile, IOMode(ReadWriteMode), Handle) -import Environment -import Plugins (tenthSeconds, Exec(alias, start), hGetLineSafe) -import System.Posix.Files (getFileStatus, isNamedPipe) -import Control.Concurrent(forkIO, threadDelay) -import Control.Concurrent.STM (TChan, atomically, writeTChan, tryReadTChan, newTChan) -import Control.Exception -import Control.Monad(forever, unless) -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/Plugins/Monitors.hs b/src/Plugins/Monitors.hs deleted file mode 100644 --- a/src/Plugins/Monitors.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Plugins.Monitors --- Copyright : (c) 2010, 2011, 2012, 2013, 2017 Jose Antonio Ortega Ruiz --- (c) 2007-10 Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- The system monitor plugin for Xmobar. --- ------------------------------------------------------------------------------ - -module Plugins.Monitors where - -import Plugins - -import Plugins.Monitors.Common (runM, runMD) -#ifdef WEATHER -import Plugins.Monitors.Weather -#endif -import Plugins.Monitors.Net -import Plugins.Monitors.Mem -import Plugins.Monitors.Swap -import Plugins.Monitors.Cpu -import Plugins.Monitors.MultiCpu -import Plugins.Monitors.Batt -import Plugins.Monitors.Bright -import Plugins.Monitors.Thermal -import Plugins.Monitors.ThermalZone -import Plugins.Monitors.CpuFreq -import Plugins.Monitors.CoreTemp -import Plugins.Monitors.Disk -import Plugins.Monitors.Top -import Plugins.Monitors.Uptime -import Plugins.Monitors.CatInt -#ifdef UVMETER -import Plugins.Monitors.UVMeter -#endif -#ifdef IWLIB -import Plugins.Monitors.Wireless -#endif -#ifdef LIBMPD -import Plugins.Monitors.MPD -import Plugins.Monitors.Common (runMBD) -#endif -#ifdef ALSA -import Plugins.Monitors.Volume -#endif -#ifdef MPRIS -import 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 -#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 -#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 -#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/Plugins/Monitors/Batt.hs b/src/Plugins/Monitors/Batt.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Batt.hs +++ /dev/null @@ -1,247 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 --- Stability : unstable --- Portability : unportable --- --- A battery monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where - -import Control.Exception (SomeException, handle) -import 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: , % / " -- 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 = "" ++ str ++ "" - 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/Plugins/Monitors/Bright.hs b/src/Plugins/Monitors/Bright.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Bright.hs +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------ ----- | ----- Module : Plugins.Monitors.Birght ----- Copyright : (c) Martin Perner ----- License : BSD-style (see LICENSE) ----- ----- Maintainer : Martin Perner ----- Stability : unstable ----- Portability : unportable ----- ----- A screen brightness monitor for Xmobar ----- -------------------------------------------------------------------------------- - -module 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 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 "" -- 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/Plugins/Monitors/CatInt.hs b/src/Plugins/Monitors/CatInt.hs deleted file mode 100644 --- a/src/Plugins/Monitors/CatInt.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CatInt --- Copyright : (c) Nathaniel Wesley Filardo --- License : BSD-style (see LICENSE) --- --- Maintainer : Nathaniel Wesley Filardo --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CatInt where - -import Plugins.Monitors.Common -import Plugins.Monitors.CoreCommon - -catIntConfig :: IO MConfig -catIntConfig = mkMConfig "" ["v"] - -runCatInt :: FilePath -> [String] -> Monitor String -runCatInt p _ = - let failureMessage = "Cannot read: " ++ show p - fmt x = show (truncate x :: Int) - in checkedDataRetrieval failureMessage [[p]] Nothing id fmt diff --git a/src/Plugins/Monitors/Common.hs b/src/Plugins/Monitors/Common.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Common.hs +++ /dev/null @@ -1,544 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 --- Stability : unstable --- Portability : unportable --- --- Utilities used by xmobar's monitors --- ------------------------------------------------------------------------------ - -module 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 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 "" - (_, _, 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 "") <|> try ( - do string " char ',' <|> char '#') - char '>' - return $ "") - --- | Recognizes icon specification and returns it unchanged -iconSpec :: Parser String -iconSpec = try (do string "") (try (string "/>")) - return $ "") - --- | 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 $ - "" ++ str ++ "" - -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/Plugins/Monitors/CoreCommon.hs b/src/Plugins/Monitors/CoreCommon.hs deleted file mode 100644 --- a/src/Plugins/Monitors/CoreCommon.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE CPP, PatternGuards #-} - ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CoreCommon --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek --- Stability : unstable --- Portability : unportable --- --- The common part for cpu core monitors (e.g. cpufreq, coretemp) --- ------------------------------------------------------------------------------ - -module 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 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/Plugins/Monitors/CoreTemp.hs b/src/Plugins/Monitors/CoreTemp.hs deleted file mode 100644 --- a/src/Plugins/Monitors/CoreTemp.hs +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CoreTemp --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek --- Stability : unstable --- Portability : unportable --- --- A core temperature monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CoreTemp where - -import Plugins.Monitors.Common -import 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: 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"] - path'' = ["/sys/class/hwmon/hwmon", "/device/hwmon/hwmon", "/temp", "_input"] - lbl = Just ("_label", read . dropWhile (not . isDigit)) - divisor = 1e3 :: Double - show' = showDigits (max 0 dn) - checkedDataRetrieval failureMessage [path, path', path''] lbl (/divisor) show' diff --git a/src/Plugins/Monitors/Cpu.hs b/src/Plugins/Monitors/Cpu.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Cpu.hs +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 --- Stability : unstable --- Portability : unportable --- --- A cpu monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Cpu (startCpu) where - -import Plugins.Monitors.Common -import qualified Data.ByteString.Lazy.Char8 as B -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import System.Console.GetOpt - -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: %" - ["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/Plugins/Monitors/CpuFreq.hs b/src/Plugins/Monitors/CpuFreq.hs deleted file mode 100644 --- a/src/Plugins/Monitors/CpuFreq.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CpuFreq --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek --- Stability : unstable --- Portability : unportable --- --- A cpu frequency monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CpuFreq where - -import Plugins.Monitors.Common -import Plugins.Monitors.CoreCommon - --- | --- Cpu frequency default configuration. Default template contains only --- one core frequency, user should specify custom template in order to --- get more cpu frequencies. -cpuFreqConfig :: IO MConfig -cpuFreqConfig = - mkMConfig "Freq: " (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/Plugins/Monitors/Disk.hs b/src/Plugins/Monitors/Disk.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Disk.hs +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Disk --- Copyright : (c) 2010, 2011, 2012, 2014 Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- Disk usage and throughput monitors for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where - -import Plugins.Monitors.Common -import 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/Plugins/Monitors/MPD.hs b/src/Plugins/Monitors/MPD.hs deleted file mode 100644 --- a/src/Plugins/Monitors/MPD.hs +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.MPD --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- MPD status and song --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait, mpdReady ) where - -import Data.List -import Data.Maybe (fromMaybe) -import Plugins.Monitors.Common -import System.Console.GetOpt -import qualified Network.MPD as M -import Control.Concurrent (threadDelay) - -mpdConfig :: IO MConfig -mpdConfig = mkMConfig "MPD: " - [ "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/Plugins/Monitors/Mem.hs b/src/Plugins/Monitors/Mem.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Mem.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Mem --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A memory monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where - -import Plugins.Monitors.Common -import qualified Data.Map as M -import System.Console.GetOpt - -data MemOpts = MemOpts - { usedIconPattern :: Maybe IconPattern - , freeIconPattern :: Maybe IconPattern - , availableIconPattern :: Maybe IconPattern - } - -defaultOpts :: MemOpts -defaultOpts = MemOpts - { usedIconPattern = Nothing - , freeIconPattern = Nothing - , availableIconPattern = Nothing - } - -options :: [OptDescr (MemOpts -> MemOpts)] -options = - [ Option "" ["used-icon-pattern"] (ReqArg (\x o -> - o { usedIconPattern = Just $ parseIconPattern x }) "") "" - , Option "" ["free-icon-pattern"] (ReqArg (\x o -> - o { freeIconPattern = Just $ parseIconPattern x }) "") "" - , Option "" ["available-icon-pattern"] (ReqArg (\x o -> - o { availableIconPattern = Just $ parseIconPattern x }) "") "" - ] - -parseOpts :: [String] -> IO MemOpts -parseOpts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs - -memConfig :: IO MConfig -memConfig = mkMConfig - "Mem: % (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/Plugins/Monitors/Mpris.hs b/src/Plugins/Monitors/Mpris.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Mpris.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - ----------------------------------------------------------------------------- --- | --- Module : Plugins.Monitors.Mpris --- Copyright : (c) Artem Tarasov --- License : BSD-style (see LICENSE) --- --- Maintainer : Artem Tarasov --- Stability : unstable --- Portability : unportable --- --- MPRIS song info --- ----------------------------------------------------------------------------- - -module Plugins.Monitors.Mpris ( mprisConfig, runMPRIS1, runMPRIS2 ) where - --- TODO: listen to signals - -import 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 " - " - [ "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/Plugins/Monitors/MultiCpu.hs b/src/Plugins/Monitors/MultiCpu.hs deleted file mode 100644 --- a/src/Plugins/Monitors/MultiCpu.hs +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.MultiCpu (startMultiCpu) where - -import Plugins.Monitors.Common -import Control.Applicative ((<$>)) -import qualified Data.ByteString.Lazy.Char8 as B -import Data.List (isPrefixOf, transpose, unfoldr) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import System.Console.GetOpt - -data MultiCpuOpts = MultiCpuOpts - { loadIconPatterns :: [IconPattern] - , loadIconPattern :: Maybe IconPattern - , 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/Plugins/Monitors/Net.hs b/src/Plugins/Monitors/Net.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Net.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Net ( - startNet - , startDynNet - ) where - -import 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/Plugins/Monitors/Swap.hs b/src/Plugins/Monitors/Swap.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Swap.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Swap where - -import 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/Plugins/Monitors/Thermal.hs b/src/Plugins/Monitors/Thermal.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Thermal.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Thermal where - -import qualified Data.ByteString.Lazy.Char8 as B -import 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/Plugins/Monitors/ThermalZone.hs b/src/Plugins/Monitors/ThermalZone.hs deleted file mode 100644 --- a/src/Plugins/Monitors/ThermalZone.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- | --- 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 Plugins.Monitors.ThermalZone (thermalZoneConfig, runThermalZone) where - -import Plugins.Monitors.Common - -import System.Posix.Files (fileExist) -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" - parse = return . (read :: String -> Int) . B.unpack - exists <- io $ fileExist file - if exists - then do mdegrees <- io $ B.readFile file >>= parse - temp <- showWithColors show (mdegrees `quot` 1000) - parseTemplate [ temp ] - else getConfigValue naString diff --git a/src/Plugins/Monitors/Top.hs b/src/Plugins/Monitors/Top.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Top.hs +++ /dev/null @@ -1,186 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Top --- Copyright : (c) 2010, 2011, 2012, 2013, 2014 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 Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where - -import 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] - -handleProcesses :: ([String] -> a) -> IO [a] -handleProcesses f = - fmap (foldl' (\a p -> if length p < 15 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/Plugins/Monitors/UVMeter.hs b/src/Plugins/Monitors/UVMeter.hs deleted file mode 100644 --- a/src/Plugins/Monitors/UVMeter.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# 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 Plugins.Monitors.UVMeter where - -import 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/Plugins/Monitors/Uptime.hs b/src/Plugins/Monitors/Uptime.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Uptime.hs +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- | --- 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 Plugins.Monitors.Uptime (uptimeConfig, runUptime) where - -import 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/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Volume.hs +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Volume --- Copyright : (c) 2011, 2013, 2015 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 Plugins.Monitors.Volume (runVolume, volumeConfig) where - -import Control.Applicative ((<$>)) -import Control.Monad ( liftM2, liftM3, mplus ) -import Data.Traversable (sequenceA) -import 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 - (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/Plugins/Monitors/Weather.hs b/src/Plugins/Monitors/Weather.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Weather.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# 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 Plugins.Monitors.Weather where - -import 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/Plugins/Monitors/Wireless.hs b/src/Plugins/Monitors/Wireless.hs deleted file mode 100644 --- a/src/Plugins/Monitors/Wireless.hs +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Wireless (wirelessConfig, runWireless) where - -import System.Console.GetOpt - -import 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 - 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] diff --git a/src/Plugins/PipeReader.hs b/src/Plugins/PipeReader.hs deleted file mode 100644 --- a/src/Plugins/PipeReader.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.PipeReader where - -import System.IO -import Plugins -import 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/Plugins/StdinReader.hs b/src/Plugins/StdinReader.hs deleted file mode 100644 --- a/src/Plugins/StdinReader.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.StdinReader (StdinReader(..)) where - -import Prelude -import System.Posix.Process -import System.Exit -import System.IO -import Control.Exception (SomeException(..), handle) -import Plugins -import 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/Plugins/Utils.hs b/src/Plugins/Utils.hs deleted file mode 100644 --- a/src/Plugins/Utils.hs +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- | --- 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 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/Plugins/XMonadLog.hs b/src/Plugins/XMonadLog.hs deleted file mode 100644 --- a/src/Plugins/XMonadLog.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# 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 Plugins.XMonadLog (XMonadLog(..)) where - -import Control.Monad -import Graphics.X11 -import Graphics.X11.Xlib.Extras -import Plugins -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar) -import XUtil (nextEvent') -import Actions (stripActions) - -data XMonadLog = XMonadLog - | UnsafeXMonadLog - | XPropertyLog String - | UnsafeXPropertyLog String - | NamedXPropertyLog String String - | UnsafeNamedXPropertyLog String String - deriving (Read, Show) - -instance Exec XMonadLog where - alias XMonadLog = "XMonadLog" - alias UnsafeXMonadLog = "UnsafeXMonadLog" - alias (XPropertyLog atom) = atom - alias (NamedXPropertyLog _ name) = name - alias (UnsafeXPropertyLog atom) = atom - alias (UnsafeNamedXPropertyLog _ name) = name - - start x cb = do - let atom = case x of - XMonadLog -> "_XMONAD_LOG" - 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/Runnable.hs b/src/Runnable.hs deleted file mode 100644 --- a/src/Runnable.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# 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 Runnable where - -import Control.Monad -import Text.Read -import Config (runnableTypes) -import 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/Runnable.hs-boot b/src/Runnable.hs-boot deleted file mode 100644 --- a/src/Runnable.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Runnable where -import Commands - -data Runnable = forall r . (Exec r,Read r,Show r) => Run r - -instance Read Runnable -instance Exec Runnable diff --git a/src/Signal.hs b/src/Signal.hs deleted file mode 100644 --- a/src/Signal.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# 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 Signal where - -import Data.Typeable (Typeable) -import Control.Concurrent.STM -import Control.Exception -import System.Posix.Signals -import Graphics.X11.Types (Button) -import Graphics.X11.Xlib.Types (Position) - -#ifdef DBUS -import DBus (IsVariant(..)) -import Control.Monad ((>=>)) -#endif - -import 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 () diff --git a/src/StatFS.hsc b/src/StatFS.hsc deleted file mode 100644 --- a/src/StatFS.hsc +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 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/Window.hs b/src/Window.hs deleted file mode 100644 --- a/src/Window.hs +++ /dev/null @@ -1,214 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 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 Config -import 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/XPMFile.hsc b/src/XPMFile.hsc deleted file mode 100644 --- a/src/XPMFile.hsc +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : XPMFile --- Copyright : (C) 2014 Alexander Shabalin --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module XPMFile(readXPMFile) where - -#if MIN_VERSION_mtl(2, 2, 1) -import Control.Monad.Except(MonadError(..)) -#else -import Control.Monad.Error(MonadError(..)) -#endif -import Control.Monad.Trans(MonadIO(..)) -import Graphics.X11.Xlib(Dimension, Display(..), Drawable, Pixmap) -import Foreign.C.String(CString, withCString) -import Foreign.C.Types(CInt(..), CLong) -import Foreign.Ptr(Ptr) -import Foreign.Marshal.Alloc(alloca, allocaBytes) -import Foreign.Storable(peek, peekByteOff, pokeByteOff) - -#include <X11/xpm.h> - -foreign import ccall "XpmReadFileToPixmap" - xpmReadFileToPixmap :: Display -> Drawable -> CString -> Ptr Pixmap -> Ptr Pixmap -> Ptr () -> IO CInt - -readXPMFile - :: (MonadError String m, MonadIO m) - => Display - -> Drawable - -> String - -> m (Dimension, Dimension, Pixmap, Maybe Pixmap) -readXPMFile display d filename = - toError $ withCString filename $ \c_filename -> - alloca $ \pixmap_return -> - alloca $ \shapemask_return -> - allocaBytes (#size XpmAttributes) $ \attributes -> do - (#poke XpmAttributes, valuemask) attributes ((#const XpmReturnAllocPixels) :: CLong) - res <- xpmReadFileToPixmap display d c_filename pixmap_return shapemask_return attributes - case res of - 0 -> do - width <- (#peek XpmAttributes, width) attributes - height <- (#peek XpmAttributes, height) attributes - pixmap <- peek pixmap_return - shapemask <- peek shapemask_return - return $ Right (width, height, pixmap, if shapemask == 0 then Nothing else Just shapemask) - 1 -> return $ Left "readXPMFile: XpmColorError" - -1 -> return $ Left "readXPMFile: XpmOpenFailed" - -2 -> return $ Left "readXPMFile: XpmFileInvalid" - -3 -> return $ Left "readXPMFile: XpmNoMemory" - -4 -> return $ Left "readXPMFile: XpmColorFailed" - _ -> return $ Left "readXPMFile: Unknown error" - where toError m = either throwError return =<< liftIO m diff --git a/src/XUtil.hsc b/src/XUtil.hsc deleted file mode 100644 --- a/src/XUtil.hsc +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 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 MinXft -import Graphics.X11.Xrender -#endif - -import 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 diff --git a/src/Xmobar.hs b/src/Xmobar.hs --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Xmobar @@ -14,348 +15,53 @@ -- ----------------------------------------------------------------------------- -module Xmobar - ( -- * Main Stuff - -- $main - X , XConf (..), runX - , startLoop - -- * Program Execution - -- $command - , startCommand - -- * Window Management - -- $window - , createWin - -- * Printing - -- $print - , drawInWin, printStrings - ) where - -import Prelude hiding (lookup) -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama -import Graphics.X11.Xrandr - -import Control.Arrow ((&&&)) -import Control.Applicative ((<$>)) -import Control.Monad.Reader -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception (handle, SomeException(..)) -import Data.Bits -import Data.Map hiding (foldr, map, filter) -import Data.Maybe (fromJust, isJust) - -import Bitmap -import Config -import Parsers -import Commands -import Actions -import Runnable -import Signal -import Window -import XUtil -import ColorCache - -#ifdef XFT -import Graphics.X11.Xft -import MinXft (drawBackground) -#endif - -#ifdef DBUS -import IPC.DBus -#endif - --- $main --- --- The Xmobar data type and basic loops and functions. - --- | The X type is a ReaderT -type X = ReaderT XConf IO - --- | The ReaderT inner component -data XConf = - XConf { display :: Display - , rect :: Rectangle - , window :: Window - , fontListS :: [XFont] - , verticalOffsets :: [Int] - , iconS :: Map FilePath Bitmap - , config :: Config - } - --- | Runs the ReaderT -runX :: XConf -> X () -> IO () -runX xc f = runReaderT f xc - --- | Starts the main event loop and threads -startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] - -> IO () -startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do -#ifdef XFT - xftInitFtLibrary -#endif - tv <- atomically $ newTVar [] - _ <- forkIO (handle (handler "checker") (checker tv [] vs sig)) -#ifdef THREADED_RUNTIME - _ <- forkOS (handle (handler "eventer") (eventer sig)) -#else - _ <- forkIO (handle (handler "eventer") (eventer sig)) -#endif -#ifdef DBUS - runIPC sig +module Xmobar (xmobar + , xmobarMain + , defaultConfig + , Runnable (..) + , Exec (..) + , module Xmobar.Config.Types + , module Xmobar.Config.Parse + , module Xmobar.Plugins.BufferedPipeReader + , module Xmobar.Plugins.CommandReader + , module Xmobar.Plugins.Date +#ifdef DATEZONE + , module Xmobar.Plugins.DateZone #endif - eventLoop tv xcfg [] sig - where - handler thing (SomeException e) = - void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) - -- Reacts on events from X - eventer signal = - allocaXEvent $ \e -> do - dpy <- openDisplay "" - xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) - - forever $ do -#ifdef THREADED_RUNTIME - nextEvent dpy e -#else - nextEvent' dpy e + , module Xmobar.Plugins.EWMH + , module Xmobar.Plugins.Kbd + , module Xmobar.Plugins.Locks +#ifdef INOTIFY + , module Xmobar.Plugins.Mail + , module Xmobar.Plugins.MBox #endif - ev <- getEvent e - case ev of - ConfigureEvent {} -> atomically $ putTMVar signal Reposition - ExposeEvent {} -> atomically $ putTMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) - _ -> return () - --- | Send signal to eventLoop every time a var is updated -checker :: TVar [String] - -> [String] - -> [[(Maybe ThreadId, TVar String)]] - -> TMVar SignalType - -> IO () -checker tvar ov vs signal = do - nval <- atomically $ do - nv <- mapM concatV vs - guard (nv /= ov) - writeTVar tvar nv - return nv - atomically $ putTMVar signal Wakeup - checker tvar nval vs signal - where - concatV = fmap concat . mapM (readTVar . snd) - - --- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] - -> XConf - -> [([Action], Position, Position)] - -> TMVar SignalType - -> IO () -eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do - typ <- atomically $ takeTMVar signal - case typ of - Wakeup -> do - str <- updateString cfg tv - xc' <- updateCache d w is (iconRoot cfg) str >>= - \c -> return xc { iconS = c } - as' <- updateActions xc r str - runX xc' $ drawInWin r str - eventLoop tv xc' as' signal - - Reposition -> - reposWindow cfg - - ChangeScreen -> do - ncfg <- updateConfigPosition cfg - reposWindow ncfg - - Hide t -> hide (t*100*1000) - Reveal t -> reveal (t*100*1000) - Toggle t -> toggle t - - TogglePersistent -> eventLoop - tv xc { config = cfg { persistent = not $ persistent cfg } } as signal - - Action but x -> action but x - - where - isPersistent = not $ persistent cfg - - hide t - | t == 0 = - when isPersistent (hideWindow d w) >> eventLoop tv xc as signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - eventLoop tv xc as signal - - reveal t - | t == 0 = do - when isPersistent (showWindow r cfg d w) - eventLoop tv xc as signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) - eventLoop tv xc as signal - - toggle t = do - ismapped <- isMapped d w - atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - eventLoop tv xc as signal - - reposWindow rcfg = do - r' <- repositionWin d w (head fs) rcfg - eventLoop tv (XConf d r' w fs vos is rcfg) as signal - - updateConfigPosition ocfg = - case position ocfg of - OnScreen n o -> do - srs <- getScreenInfo d - return (if n == length srs - then - (ocfg {position = OnScreen 1 o}) - else - (ocfg {position = OnScreen (n+1) o})) - o -> return (ocfg {position = OnScreen 1 o}) - - action button x = do - mapM_ runAction $ - filter (\(Spawn b _) -> button `elem` b) $ - concatMap (\(a,_,_) -> a) $ - filter (\(_, from, to) -> x >= from && x <= to) as - eventLoop tv xc as signal - --- $command - --- | Runs a command as an independent thread and returns its thread id --- and the TVar the command will be writing to. -startCommand :: TMVar SignalType - -> (Runnable,String,String) - -> IO (Maybe ThreadId, TVar String) -startCommand sig (com,s,ss) - | alias com == "" = do var <- atomically $ newTVar is - atomically $ writeTVar var (s ++ ss) - return (Nothing,var) - | otherwise = do var <- atomically $ newTVar is - let cb str = atomically $ writeTVar var (s ++ str ++ ss) - h <- forkIO $ start com cb - _ <- forkIO $ trigger com $ maybe (return ()) - (atomically . putTMVar sig) - return (Just h,var) - where is = s ++ "Updating..." ++ ss - -updateString :: Config -> TVar [String] - -> IO [[(Widget, String, Int, Maybe [Action])]] -updateString conf v = do - s <- readTVarIO v - let l:c:r:_ = s ++ repeat "" - io $ mapM (parseString conf) [l, c, r] - -updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]] - -> IO [([Action], Position, Position)] -updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do - let (d,fs) = (display &&& fontListS) conf - strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] - strLn = io . mapM getCoords - iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) - getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw) - getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) - partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ - filter (\(a, _,_) -> isJust a) $ - scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) - (Nothing, 0, off) - xs - totSLen = foldr (\(_,_,len) -> (+) len) 0 - remWidth xs = fi wid - totSLen xs - offs = 1 - offset a xs = case a of - C -> (remWidth xs + offs) `div` 2 - R -> remWidth xs - L -> offs - fmap concat $ mapM (\(a,xs) -> - (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ - zip [L,C,R] [left,center,right] - --- $print - --- | Draws in and updates the window -drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X () -drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do - r <- ask - let (c,d) = (config &&& display) r - (w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r - strLn = io . mapM getWidth - iconW i = maybe 0 Bitmap.width (lookup i $ iconS r) - getWidth (Text s,cl,i,_) = - textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw) - getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) + , module Xmobar.Plugins.Monitors + , module Xmobar.Plugins.PipeReader + , module Xmobar.Plugins.StdinReader + , module Xmobar.Plugins.XMonadLog + ) where - p <- io $ createPixmap d w wid ht - (defaultDepthOfScreen (defaultScreenOfDisplay d)) -#if XFT - when (alpha c /= 255) (io $ drawBackground d p (bgColor c) (alpha c) wr) +import Xmobar.Run.Runnable +import Xmobar.Run.Commands +import Xmobar.Config.Types +import Xmobar.Config.Parse +import Xmobar.Plugins.BufferedPipeReader +import Xmobar.Plugins.CommandReader +import Xmobar.Plugins.Date +#ifdef DATEZONE +import Xmobar.Plugins.DateZone #endif - withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do - gc <- io $ createGC d w -#if XFT - when (alpha c == 255) $ do -#else - do +import Xmobar.Plugins.EWMH +import Xmobar.Plugins.Kbd +import Xmobar.Plugins.Locks +#ifdef INOTIFY +import Xmobar.Plugins.Mail +import Xmobar.Plugins.MBox #endif - io $ setForeground d gc bgcolor - io $ fillRectangle d p gc 0 0 wid ht - -- write to the pixmap the new string - printStrings p gc fs vs 1 L =<< strLn left - printStrings p gc fs vs 1 R =<< strLn right - printStrings p gc fs vs 1 C =<< strLn center - -- draw border if requested - io $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht - -- copy the pixmap with the new string to the window - io $ copyArea d p w gc 0 0 wid ht 0 0 - -- free up everything (we do not want to leak memory!) - io $ freeGC d gc - io $ freePixmap d p - -- resync - io $ sync d True - -verticalOffset :: (Integral b, Integral a, MonadIO m) => - a -> Widget -> XFont -> Int -> Config -> m b -verticalOffset ht (Text t) fontst voffs _ - | voffs > -1 = return $ fi voffs - | otherwise = do - (as,ds) <- io $ textExtents fontst t - let margin = (fi ht - fi ds - fi as) `div` 2 - return $ fi as + margin - 1 -verticalOffset ht (Icon _) _ _ conf - | iconOffset conf > -1 = return $ fi (iconOffset conf) - | otherwise = return $ fi (ht `div` 2) - 1 +import Xmobar.Plugins.Monitors +import Xmobar.Plugins.PipeReader +import Xmobar.Plugins.StdinReader +import Xmobar.Plugins.XMonadLog --- | An easy way to print the stuff we need to print -printStrings :: Drawable -> GC -> [XFont] -> [Int] -> Position - -> Align -> [(Widget, String, Int, Position)] -> X () -printStrings _ _ _ _ _ _ [] = return () -printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do - r <- ask - let (conf,d) = (config &&& display) r - alph = alpha conf - Rectangle _ _ wid ht = rect r - totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl - remWidth = fi wid - fi totSLen - fontst = fontlist !! i - offset = case a of - C -> (remWidth + offs) `div` 2 - R -> remWidth - L -> offs - (fc,bc) = case break (==',') c of - (f,',':b) -> (f, b ) - (f, _) -> (f, bgColor conf) - valign <- verticalOffset ht s (head fontlist) (voffs !! i) conf - case s of - (Text t) -> io $ printString d dr fontst gc fc bc offset valign t alph - (Icon p) -> io $ maybe (return ()) - (drawBitmap d dr gc fc bc offset valign) - (lookup p (iconS r)) - printStrings dr gc fontlist voffs (offs + l) a xs +import Xmobar.App.Main(xmobar, xmobarMain) +import Xmobar.App.Config(defaultConfig) diff --git a/src/Xmobar/App/Compile.hs b/src/Xmobar/App/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/App/Compile.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.App.Compile +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Mon Nov 26, 2018 03:36 +-- +-- +-- Utlities to compile xmobar executables on the fly +-- +------------------------------------------------------------------------------ + + +module Xmobar.App.Compile(recompile, xmessage) where + +import Control.Monad.IO.Class +import Control.Monad.Fix (fix) +import Control.Exception.Extensible (try, bracket, SomeException(..)) +import qualified Control.Exception.Extensible as E +import Control.Monad (filterM, when) +import Data.List ((\\)) +import Data.Maybe (isJust) +import System.FilePath((</>), takeExtension) +import System.IO +import System.Directory +import System.Process +import System.Exit +import System.Posix.Process(executeFile, forkProcess, getAnyProcessStatus) +import System.Posix.Types(ProcessID) +import System.Posix.Signals + +isExecutable :: FilePath -> IO Bool +isExecutable f = + E.catch (executable <$> getPermissions f) (\(SomeException _) -> return False) + +checkBuildScript :: Bool -> FilePath -> IO Bool +checkBuildScript verb buildscript = do + exists <- doesFileExist buildscript + if exists + then do + isExe <- isExecutable buildscript + if isExe + then do + trace verb $ "Xmobar will use build script at " + ++ show buildscript ++ " to recompile." + return True + else do + trace verb $ unlines + [ "Xmobar will not use build script, because " + ++ show buildscript ++ " is not executable." + , "Suggested resolution to use it: chmod u+x " + ++ show buildscript + ] + return False + else do + trace verb $ "Xmobar will use ghc to recompile, because " + ++ show buildscript ++ " does not exist." + return False + +shouldRecompile :: Bool -> FilePath -> FilePath -> FilePath -> IO Bool +shouldRecompile verb src bin lib = do + libTs <- mapM getModTime . filter isSource =<< allFiles lib + srcT <- getModTime src + binT <- getModTime bin + if any (binT <) (srcT : libTs) + then do + trace verb "Xmobar doing recompile because some files have changed." + return True + else do + trace verb $ "Xmobar skipping recompile because it is not forced " + ++ "(e.g. via --recompile), and not any *.hs / *.lhs / *.hsc" + ++ "files in lib/ have been changed." + return False + where isSource = flip elem [".hs",".lhs",".hsc"] . takeExtension + allFiles t = do + let prep = map (t</>) . Prelude.filter (`notElem` [".",".."]) + cs <- prep <$> E.catch (getDirectoryContents t) + (\(SomeException _) -> return []) + ds <- filterM doesDirectoryExist cs + concat . ((cs \\ ds):) <$> mapM allFiles ds + getModTime f = E.catch (Just <$> getModificationTime f) + (\(SomeException _) -> return Nothing) + +runProc :: FilePath -> [String] -> FilePath -> Handle -> IO ProcessHandle +runProc bin args dir eh = + runProcess bin args (Just dir) Nothing Nothing Nothing (Just eh) + +xmessage :: String -> IO System.Posix.Types.ProcessID +xmessage msg = forkProcess $ + executeFile "xmessage" True ["-default", "okay", replaceUnicode msg] Nothing + where -- Replace some of the unicode symbols GHC uses in its output + replaceUnicode = map $ \c -> case c of + '\8226' -> '*' -- • + '\8216' -> '`' -- ‘ + '\8217' -> '`' -- ’ + _ -> c + +ghcErrorMsg :: (Monad m, Show a) => String -> a -> String -> m String +ghcErrorMsg src status ghcErr = return . unlines $ + ["Error detected while loading xmobar configuration file: " ++ src] + ++ lines (if null ghcErr then show status else ghcErr) + ++ ["","Please check the file for errors."] + +-- | A 'trace' for the 'X' monad. Logs a string to stderr. The result may +-- be found in your .xsession-errors file +trace :: MonadIO m => Bool -> String -> m () +trace verb msg = when verb (liftIO $ hPutStrLn stderr msg) + +-- | 'recompile force', recompile the xmobar configuration file when +-- any of the following apply: +-- +-- * force is 'True' +-- +-- * the execName executable does not exist +-- +-- * the xmobar executable is older than .hs or any file in +-- the @lib@ directory (under the configuration directory). +-- +-- The -i flag is used to restrict recompilation to the xmobar.hs file only, +-- and any files in the aforementioned @lib@ directory. +-- +-- Compilation errors (if any) are logged to the @xmobar.errors@ file +-- in the given directory. If GHC indicates failure with a +-- non-zero exit code, an xmessage displaying that file is spawned. +-- +-- 'False' is returned if there are compilation errors. +-- +recompile :: MonadIO m => String -> String -> Bool -> Bool -> m Bool +recompile dir execName force verb = liftIO $ do + let bin = dir </> execName + err = dir </> (execName ++ ".errors") + src = dir </> (execName ++ ".hs") + lib = dir </> "lib" + script = dir </> "build" + useScript <- checkBuildScript verb script + sc <- if useScript || force + then return True + else shouldRecompile verb src bin lib + if sc + then do + uninstallSignalHandlers + status <- bracket (openFile err WriteMode) hClose $ + \errHandle -> + waitForProcess =<< + if useScript + then runScript script bin dir errHandle + else runGHC bin dir errHandle + installSignalHandlers + if status == ExitSuccess + then trace verb "Xmobar recompilation process exited with success!" + else do + msg <- readFile err >>= ghcErrorMsg src status + hPutStrLn stderr msg + exitWith (ExitFailure 1) + return (status == ExitSuccess) + else return True + where opts bin = ["--make" , execName ++ ".hs" , "-i" , "-ilib" + , "-fforce-recomp" , "-main-is", "main" , "-v0"] +#ifdef THREADED_RUNTIME + ++ ["-threaded"] +#endif +#ifdef DRTSOPTS + ++ ["-rtsopts", "-with-rtsopts", "-V0"] +#endif + ++ ["-o", bin] + runGHC bin = runProc "ghc" (opts bin) + runScript script bin = runProc script [bin] + +-- | Ignore SIGPIPE to avoid termination when a pipe is full, and SIGCHLD to +-- avoid zombie processes, and clean up any extant zombie processes. +installSignalHandlers :: MonadIO m => m () +installSignalHandlers = liftIO $ do + installHandler openEndedPipe Ignore Nothing + installHandler sigCHLD Ignore Nothing + (try :: IO a -> IO (Either SomeException a)) + $ fix $ \more -> do + x <- getAnyProcessStatus False False + when (isJust x) more + return () + +uninstallSignalHandlers :: MonadIO m => m () +uninstallSignalHandlers = liftIO $ do + installHandler openEndedPipe Default Nothing + installHandler sigCHLD Default Nothing + return () diff --git a/src/Xmobar/App/Config.hs b/src/Xmobar/App/Config.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/App/Config.hs @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Config.Defaults +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sun Nov 25, 2018 22:26 +-- +-- +-- Default values for Xmobar configurations and functions to access +-- configuration files and directories. +-- +------------------------------------------------------------------------------ + + +module Xmobar.App.Config (defaultConfig, + xmobarConfigDir, + xmobarDataDir, + xmobarConfigFile) where + +import System.Environment +import System.Directory +import System.FilePath ((</>)) +import System.Posix.Files (fileExist) + +import Xmobar.Plugins.Date +import Xmobar.Plugins.StdinReader +import Xmobar.Config.Types +import Xmobar.Run.Runnable + +-- | 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>" + , verbose = False + } + +-- | Return the path to the xmobar configuration directory. This +-- directory is where user configuration files are stored (e.g, the +-- xmobar.hs file). You may also create a @lib@ subdirectory in the +-- configuration directory and the default recompile command will add +-- it to the GHC include path. +-- +-- Several directories are considered. In order of +-- preference: +-- +-- 1. The directory specified in the @XMOBAR_CONFIG_DIR@ environment variable. +-- 2. The @~\/.xmobar@ directory. +-- 3. The @XDG_CONFIG_HOME/xmobar@ directory. +-- +-- The first directory that exists will be used. If none of the +-- directories exist then (1) will be used if it is set, otherwise (2) +-- will be used. Either way, a directory will be created if necessary. +xmobarConfigDir :: IO String +xmobarConfigDir = + findFirstDirWithEnv "XMOBAR_CONFIG_DIR" + [ getAppUserDataDirectory "xmobar" + , getXdgDirectory XdgConfig "xmobar" + ] + +-- | Return the path to the xmobar data directory. This directory is +-- used by Xmobar to store data files such as the run-time state file +-- and the configuration binary generated by GHC. +-- +-- Several directories are considered. In order of preference: +-- +-- 1. The directory specified in the @XMOBAR_DATA_DIR@ environment variable. +-- 2. The @~\/.xmobar@ directory. +-- 3. The @XDG_DATA_HOME/xmobar@ directory. +-- +-- The first directory that exists will be used. If none of the +-- directories exist then (1) will be used if it is set, otherwise (2) +-- will be used. Either way, a directory will be created if +-- necessary. +xmobarDataDir :: IO String +xmobarDataDir = + findFirstDirWithEnv "XMOBAR_DATA_DIR" + [ getAppUserDataDirectory "xmobar" + , getXdgDirectory XdgData "xmobar" + ] + +-- | Helper function that will find the first existing directory and +-- return its path. If none of the directories can be found, create +-- and return the first from the list. If the list is empty this +-- function returns the historical @~\/.xmobar@ directory. +findFirstDirOf :: [IO FilePath] -> IO FilePath +findFirstDirOf [] = findFirstDirOf [getAppUserDataDirectory "xmobar"] +findFirstDirOf possibles = do + found <- go possibles + case found of + Just path -> return path + Nothing -> do + primary <- head possibles + createDirectoryIfMissing True primary + return primary + where + go [] = return Nothing + go (x:xs) = do + exists <- x >>= doesDirectoryExist + if exists then x >>= return . Just else go xs + +-- | Simple wrapper around @findFirstDirOf@ that allows the primary +-- path to be specified by an environment variable. +findFirstDirWithEnv :: String -> [IO FilePath] -> IO FilePath +findFirstDirWithEnv envName paths = do + envPath' <- lookupEnv envName + case envPath' of + Nothing -> findFirstDirOf paths + Just envPath -> findFirstDirOf (return envPath:paths) + +xmobarConfigFile :: IO (Maybe FilePath) +xmobarConfigFile = + ffirst [ xdg "xmobar.hs", xdg "xmobarrc", home ".xmobarrc"] + where xdg p = fmap (</> p) xmobarConfigDir + home p = fmap (</> p) getHomeDirectory + ffirst [] = return Nothing + ffirst (f:fs) = + f >>= fileExist >>= \e -> if e then fmap Just f else ffirst fs diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/App/EventLoop.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.X11.EventLoop +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sat Nov 24, 2018 19:40 +-- +-- +-- Event loop +-- +------------------------------------------------------------------------------ + + +module Xmobar.App.EventLoop (startLoop, startCommand) where + +import Prelude hiding (lookup) +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama +import Graphics.X11.Xrandr + +import Control.Arrow ((&&&)) +import Control.Applicative ((<$>)) +import Control.Monad.Reader +import Control.Concurrent +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.STM +import Control.Exception (handle, SomeException(..)) +import Data.Bits +import Data.Map hiding (foldr, map, filter) +import Data.Maybe (fromJust, isJust) + +import Xmobar.System.Signal +import Xmobar.Config.Types +import Xmobar.Run.Commands +import Xmobar.Run.Runnable +import Xmobar.X11.Actions +import Xmobar.X11.Parsers +import Xmobar.X11.Window +import Xmobar.X11.Text +import Xmobar.X11.Draw +import Xmobar.X11.Bitmap as Bitmap +import Xmobar.X11.Types +import Xmobar.X11.Events(nextEvent') + +#ifdef XFT +import Graphics.X11.Xft +#endif + +#ifdef DBUS +import Xmobar.System.DBus +#endif + +runX :: XConf -> X () -> IO () +runX xc f = runReaderT f xc + +-- | Starts the main event loop and threads +startLoop :: XConf -> TMVar SignalType -> [[([Async ()], TVar String)]] + -> IO () +startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do +#ifdef XFT + xftInitFtLibrary +#endif + tv <- atomically $ newTVar [] + _ <- forkIO (handle (handler "checker") (checker tv [] vs sig)) +#ifdef THREADED_RUNTIME + _ <- forkOS (handle (handler "eventer") (eventer sig)) +#else + _ <- forkIO (handle (handler "eventer") (eventer sig)) +#endif +#ifdef DBUS + runIPC sig +#endif + eventLoop tv xcfg [] sig + where + handler thing (SomeException e) = + void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) + -- Reacts on events from X + eventer signal = + allocaXEvent $ \e -> do + dpy <- openDisplay "" + xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask + selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) + + forever $ do +#ifdef THREADED_RUNTIME + nextEvent dpy e +#else + nextEvent' dpy e +#endif + ev <- getEvent e + case ev of + ConfigureEvent {} -> atomically $ putTMVar signal Reposition + ExposeEvent {} -> atomically $ putTMVar signal Wakeup + RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition + ButtonEvent {} -> atomically $ + putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) + _ -> return () + +-- | Send signal to eventLoop every time a var is updated +checker :: TVar [String] + -> [String] + -> [[([Async ()], TVar String)]] + -> TMVar SignalType + -> IO () +checker tvar ov vs signal = do + nval <- atomically $ do + nv <- mapM concatV vs + guard (nv /= ov) + writeTVar tvar nv + return nv + atomically $ putTMVar signal Wakeup + checker tvar nval vs signal + where + concatV = fmap concat . mapM (readTVar . snd) + + +-- | Continuously wait for a signal from a thread or a interrupt handler +eventLoop :: TVar [String] + -> XConf + -> [([Action], Position, Position)] + -> TMVar SignalType + -> IO () +eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do + typ <- atomically $ takeTMVar signal + case typ of + Wakeup -> do + str <- updateString cfg tv + xc' <- updateCache d w is (iconRoot cfg) str >>= + \c -> return xc { iconS = c } + as' <- updateActions xc r str + runX xc' $ drawInWin r str + eventLoop tv xc' as' signal + + Reposition -> + reposWindow cfg + + ChangeScreen -> do + ncfg <- updateConfigPosition cfg + reposWindow ncfg + + Hide t -> hide (t*100*1000) + Reveal t -> reveal (t*100*1000) + Toggle t -> toggle t + + TogglePersistent -> eventLoop + tv xc { config = cfg { persistent = not $ persistent cfg } } as signal + + Action but x -> action but x + + where + isPersistent = not $ persistent cfg + + hide t + | t == 0 = + when isPersistent (hideWindow d w) >> eventLoop tv xc as signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Hide 0) + eventLoop tv xc as signal + + reveal t + | t == 0 = do + when isPersistent (showWindow r cfg d w) + eventLoop tv xc as signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) + eventLoop tv xc as signal + + toggle t = do + ismapped <- isMapped d w + atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) + eventLoop tv xc as signal + + reposWindow rcfg = do + r' <- repositionWin d w (head fs) rcfg + eventLoop tv (XConf d r' w fs vos is rcfg) as signal + + updateConfigPosition ocfg = + case position ocfg of + OnScreen n o -> do + srs <- getScreenInfo d + return (if n == length srs + then + (ocfg {position = OnScreen 1 o}) + else + (ocfg {position = OnScreen (n+1) o})) + o -> return (ocfg {position = OnScreen 1 o}) + + action button x = do + mapM_ runAction $ + filter (\(Spawn b _) -> button `elem` b) $ + concatMap (\(a,_,_) -> a) $ + filter (\(_, from, to) -> x >= from && x <= to) as + eventLoop tv xc as signal + +-- $command + +-- | Runs a command as an independent thread and returns its Async handles +-- and the TVar the command will be writing to. +startCommand :: TMVar SignalType + -> (Runnable,String,String) + -> IO ([Async ()], TVar String) +startCommand sig (com,s,ss) + | alias com == "" = do var <- atomically $ newTVar is + atomically $ writeTVar var (s ++ ss) + return ([], var) + | otherwise = do var <- atomically $ newTVar is + let cb str = atomically $ writeTVar var (s ++ str ++ ss) + a1 <- async $ start com cb + a2 <- async $ trigger com $ maybe (return ()) + (atomically . putTMVar sig) + return ([a1, a2], var) + where is = s ++ "Updating..." ++ ss + +updateString :: Config -> TVar [String] + -> IO [[(Widget, String, Int, Maybe [Action])]] +updateString conf v = do + s <- readTVarIO v + let l:c:r:_ = s ++ repeat "" + liftIO $ mapM (parseString conf) [l, c, r] + +updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]] + -> IO [([Action], Position, Position)] +updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do + let (d,fs) = (display &&& fontListS) conf + strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] + strLn = liftIO . mapM getCoords + iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) + getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw) + getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) + partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ + filter (\(a, _,_) -> isJust a) $ + scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) + (Nothing, 0, off) + xs + totSLen = foldr (\(_,_,len) -> (+) len) 0 + remWidth xs = fi wid - totSLen xs + offs = 1 + offset a xs = case a of + C -> (remWidth xs + offs) `div` 2 + R -> remWidth xs + L -> offs + fmap concat $ mapM (\(a,xs) -> + (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ + zip [L,C,R] [left,center,right] diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/App/Main.hs @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.App.Main +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sun Nov 25, 2018 21:53 +-- +-- +-- Support for creating executable main functions +-- +------------------------------------------------------------------------------ + + +module Xmobar.App.Main (xmobar, xmobarMain) where + +import Control.Concurrent.Async (Async, cancel) +import Control.Exception (bracket) +import Control.Monad (unless) + +import Data.Foldable (for_) +import qualified Data.Map as Map +import Data.List (intercalate) +import System.Posix.Process (executeFile) +import System.Environment (getArgs) +import System.FilePath +import System.FilePath.Posix (takeBaseName, takeDirectory) + +import Graphics.X11.Xlib + +import Xmobar.Config.Types +import Xmobar.Config.Parse +import Xmobar.System.Signal (setupSignalHandler, withDeferSignals) +import Xmobar.Run.Template +import Xmobar.X11.Types +import Xmobar.X11.Text +import Xmobar.X11.Window +import Xmobar.App.Opts +import Xmobar.App.EventLoop (startLoop, startCommand) +import Xmobar.App.Compile (recompile) +import Xmobar.App.Config + +xmobar :: Config -> IO () +xmobar conf = withDeferSignals $ do + initThreads + d <- openDisplay "" + fs <- initFont d (font conf) + fl <- mapM (initFont d) (additionalFonts conf) + cls <- mapM (parseTemplate (commands conf) (sepChar conf)) + (splitTemplate (alignSep conf) (template conf)) + sig <- setupSignalHandler + bracket (mapM (mapM $ startCommand sig) cls) + cleanupThreads + $ \vars -> do + (r,w) <- createWin d fs conf + let ic = Map.empty + to = textOffset conf + ts = textOffsets conf ++ replicate (length fl) (-1) + startLoop (XConf d r w (fs:fl) (to:ts) ic conf) sig vars + +cleanupThreads :: [[([Async ()], a)]] -> IO () +cleanupThreads vars = + for_ (concat vars) $ \(asyncs, _) -> + for_ asyncs cancel + +buildLaunch :: Bool -> Bool -> FilePath -> IO () +buildLaunch verb force p = do + let exec = takeBaseName p + dir = takeDirectory p + recompile dir exec force verb + executeFile (dir </> exec) False [] Nothing + +xmobar' :: Config -> [String] -> IO () +xmobar' cfg defs = do + unless (null defs || not (verbose cfg)) $ putStrLn $ + "Fields missing from config defaulted: " ++ intercalate "," defs + xmobar cfg + +xmobarMain :: IO () +xmobarMain = do + args <- getArgs + (flags, rest) <- getOpts args + cf <- case rest of + (c:_) -> return (Just c) + _ -> xmobarConfigFile + case cf of + Nothing -> case rest of + (c:_) -> error $ c ++ ": file not found" + _ -> xmobar defaultConfig + Just p -> do d <- doOpts defaultConfig flags + r <- readConfig d p + case r of + Left _ -> buildLaunch (verbose d) (forceRecompile flags) p + Right (c, defs) -> xmobar' c defs diff --git a/src/Xmobar/App/Opts.hs b/src/Xmobar/App/Opts.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/App/Opts.hs @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.App.Opts +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Fri Nov 30, 2018 01:19 +-- +-- +-- Command line option parsing +-- +------------------------------------------------------------------------------ + +module Xmobar.App.Opts where + +import Control.Monad (when) +import System.Console.GetOpt +import System.Exit (exitSuccess, exitWith, ExitCode(..)) +import Data.Version (showVersion) +import Text.Read (readMaybe) + +import Paths_xmobar (version) + +import Xmobar.Config.Types + +data Opts = Help + | Verbose + | Recompile + | Version + | Font String + | BgColor String + | FgColor String + | Alpha String + | T + | B + | D + | AlignSep String + | Commands String + | AddCommand String + | SepChar String + | Template String + | OnScr String + | IconRoot String + | Position String + | WmClass String + | WmName String + deriving (Show, Eq) + +options :: [OptDescr Opts] +options = + [ Option "h?" ["help"] (NoArg Help) "This help" + , Option "v" ["verbose"] (NoArg Verbose) "Emit verbose debugging messages" + , Option "r" ["recompile"] (NoArg Recompile) "Force recompilation" + , Option "V" ["version"] (NoArg Version) "Show version information" + , Option "f" ["font"] (ReqArg Font "font name") "Font name" + , Option "w" ["wmclass"] (ReqArg WmClass "class") "X11 WM_CLASS property" + , Option "n" ["wmname"] (ReqArg WmName "name") "X11 WM_NAME property" + , Option "B" ["bgcolor"] (ReqArg BgColor "bg color" ) + "The background color. Default black" + , Option "F" ["fgcolor"] (ReqArg FgColor "fg color") + "The foreground color. Default grey" + , Option "i" ["iconroot"] (ReqArg IconRoot "path") + "Root directory for icon pattern paths. Default '.'" + , Option "A" ["alpha"] (ReqArg Alpha "alpha") + "Transparency: 0 is transparent, 255 is opaque. Default: 255" + , Option "o" ["top"] (NoArg T) "Place xmobar at the top of the screen" + , Option "b" ["bottom"] (NoArg B) + "Place xmobar at the bottom of the screen" + , Option "d" ["dock"] (NoArg D) + "Don't override redirect from WM and function as a dock" + , Option "a" ["alignsep"] (ReqArg AlignSep "alignsep") + "Separators for left, center and right text\nalignment. Default: '}{'" + , Option "s" ["sepchar"] (ReqArg SepChar "char") + ("Character used to separate commands in" ++ + "\nthe output template. Default '%'") + , Option "t" ["template"] (ReqArg Template "template") + "Output template" + , Option "c" ["commands"] (ReqArg Commands "commands") + "List of commands to be executed" + , Option "C" ["add-command"] (ReqArg AddCommand "command") + "Add to the list of commands to be executed" + , Option "x" ["screen"] (ReqArg OnScr "screen") + "On which X screen number to start" + , Option "p" ["position"] (ReqArg Position "position") + "Specify position of xmobar. Same syntax as in config file" + ] + +getOpts :: [String] -> IO ([Opts], [String]) +getOpts argv = do + (o,n) <- case getOpt Permute options argv of + (o,n,[]) -> return (o,n) + (_,_,errs) -> error (concat errs ++ usage) + when (Help `elem` o) (putStr usage >> exitSuccess) + when (Version `elem` o) (putStr info >> exitSuccess) + return (o, n) + +usage :: String +usage = usageInfo header options ++ footer + where header = "Usage: xmobar [OPTION...] [FILE]\nOptions:" + footer = "\nMail bug reports and suggestions to " ++ mail ++ "\n" + +info :: String +info = "xmobar " ++ showVersion version + ++ "\n (C) 2007 - 2010 Andrea Rossato " + ++ "\n (C) 2010 - 2018 Jose A Ortega Ruiz\n " + ++ mail ++ "\n" ++ license + +mail :: String +mail = "<mail@jao.io>" + +license :: String +license = "\nThis program is distributed in the hope that it will be useful," ++ + "\nbut WITHOUT ANY WARRANTY; without even the implied warranty of" ++ + "\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." ++ + "\nSee the License for more details." + +doOpts :: Config -> [Opts] -> IO Config +doOpts conf [] = + return (conf {lowerOnStart = lowerOnStart conf && overrideRedirect conf}) +doOpts conf (o:oo) = + case o of + Help -> doOpts' conf + Version -> doOpts' conf + Recompile -> doOpts' conf + Verbose -> doOpts' (conf {verbose = True}) + Font s -> doOpts' (conf {font = s}) + WmClass s -> doOpts' (conf {wmClass = s}) + WmName s -> doOpts' (conf {wmName = s}) + BgColor s -> doOpts' (conf {bgColor = s}) + FgColor s -> doOpts' (conf {fgColor = s}) + Alpha n -> doOpts' (conf {alpha = read n}) + T -> doOpts' (conf {position = Top}) + B -> doOpts' (conf {position = Bottom}) + D -> doOpts' (conf {overrideRedirect = False}) + AlignSep s -> doOpts' (conf {alignSep = s}) + SepChar s -> doOpts' (conf {sepChar = s}) + Template s -> doOpts' (conf {template = s}) + IconRoot s -> doOpts' (conf {iconRoot = s}) + OnScr n -> doOpts' (conf {position = OnScreen (read n) $ position conf}) + Commands s -> case readCom 'c' s of + Right x -> doOpts' (conf {commands = x}) + Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) + AddCommand s -> case readCom 'C' s of + Right x -> doOpts' (conf {commands = commands conf ++ x}) + Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) + Position s -> readPosition s + where readCom c str = + case readStr str of + [x] -> Right x + _ -> Left ("xmobar: cannot read list of commands " ++ + "specified with the -" ++ c:" option\n") + readStr str = [x | (x,t) <- reads str, ("","") <- lex t] + doOpts' c = doOpts c oo + readPosition string = + case readMaybe string of + Just x -> doOpts' (conf { position = x }) + Nothing -> do + putStrLn "Can't parse position option, ignoring" + doOpts' conf + +forceRecompile :: [Opts] -> Bool +forceRecompile = elem Recompile diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Config/Parse.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE FlexibleContexts, CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Config.Parse +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sun Nov 25, 2018 23:56 +-- +-- +-- Parsing of configuration files +-- +------------------------------------------------------------------------------ + + +module Xmobar.Config.Parse(readConfig, parseConfig) where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Number (int) +import Text.ParserCombinators.Parsec.Perm ((<|?>), (<$?>), permute) +import Control.Monad.IO.Class (liftIO) + +import Xmobar.Config.Types + +#if defined XFT || defined UTF8 +import qualified System.IO as S (readFile) +#endif + +readFileSafe :: FilePath -> IO String +#if defined XFT || defined UTF8 +readFileSafe = S.readFile +#else +readFileSafe = readFile +#endif + +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 :: Config -> String -> Either ParseError (Config,[String]) +parseConfig defaultConfig = + 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 + <|?> pVerbose + + 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", "verbose" + ] + + 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" + pVerbose = readField verbose "verbose" + + 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." + +-- | Reads the configuration from a file or an error if it cannot be +-- parsed. +readConfig :: Config -> FilePath -> IO (Either ParseError (Config,[String])) +readConfig defaultConfig f = + liftIO (readFileSafe f) >>= return . parseConfig defaultConfig diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Config/Types.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- 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 types +-- +----------------------------------------------------------------------------- + +module Xmobar.Config.Types + ( -- * Configuration + -- $config + Config (..) + , XPosition (..), Align (..), Border(..) + ) where + +import Xmobar.Run.Runnable (Runnable(..)) + +-- $config +-- Configuration data type + +-- | 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 + , verbose :: Bool -- ^ Emit additional debug messages + } 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 ) diff --git a/src/Xmobar/Plugins/BufferedPipeReader.hs b/src/Xmobar/Plugins/BufferedPipeReader.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Plugins/BufferedPipeReader.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- | +-- 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(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.Run.Commands +import Xmobar.System.Signal +import Xmobar.System.Environment +import Xmobar.System.Utils(hGetLineSafe) + +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 --- /dev/null +++ b/src/Xmobar/Plugins/CommandReader.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- 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(CommandReader(..)) where + +import System.IO +import Xmobar.Run.Commands +import Xmobar.System.Utils (hGetLineSafe) +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 --- /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.Run.Commands + +#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 --- /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.Run.Commands + +#ifdef DATEZONE +import Control.Concurrent.STM + +import System.IO.Unsafe + +import Data.Time.Format +import Data.Time.LocalTime +import Data.Time.LocalTime.TimeZone.Olson +import Data.Time.LocalTime.TimeZone.Series + +import Xmobar.System.Localize + +#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 --- /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.Run.Commands +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar, CLong) +import Xmobar.X11.Events (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.hs b/src/Xmobar/Plugins/Kbd.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Plugins/Kbd.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- 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(Kbd(..)) where + +import Data.List (isPrefixOf, findIndex) +import Data.Maybe (fromJust) +import Control.Monad (forever) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Xmobar.Run.Commands +import Xmobar.X11.Events (nextEvent') +import Xmobar.System.Kbd + + +-- '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 (/= ':')) $ filter (not . null) 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 + + + +newtype 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 () diff --git a/src/Xmobar/Plugins/Locks.hs b/src/Xmobar/Plugins/Locks.hs new file mode 100644 --- /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(Locks(..)) where + +import Graphics.X11 +import Data.List +import Data.Bits +import Control.Monad +import Graphics.X11.Xlib.Extras +import Xmobar.Run.Commands +import Xmobar.System.Kbd +import Xmobar.X11.Events (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 --- /dev/null +++ b/src/Xmobar/Plugins/MBox.hs @@ -0,0 +1,132 @@ +{-# 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.Run.Commands +#ifdef INOTIFY + +import Xmobar.System.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 --- /dev/null +++ b/src/Xmobar/Plugins/Mail.hs @@ -0,0 +1,93 @@ +{-# 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(Mail(..)) where + +import Xmobar.Run.Commands +#ifdef INOTIFY + +import Xmobar.System.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 --- /dev/null +++ b/src/Xmobar/Plugins/MarqueePipeReader.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- 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.System.Environment +import Xmobar.Run.Commands(Exec(alias, start), tenthSeconds) +import Xmobar.System.Utils(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 --- /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.Run.Commands + +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/Alsa.hs b/src/Xmobar/Plugins/Monitors/Alsa.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Alsa.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Alsa +-- Copyright : (c) 2018 Daniel Schüssler +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Event-based variant of the Volume plugin. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Alsa + ( startAlsaPlugin + , withMonitorWaiter + , parseOptsIncludingMonitorArgs + , AlsaOpts(aoAlsaCtlPath) + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Xmobar.Plugins.Monitors.Common +import qualified Xmobar.Plugins.Monitors.Volume as Volume; +import System.Console.GetOpt +import System.Directory +import System.Exit +import System.IO +import System.Process + +data AlsaOpts = AlsaOpts + { aoVolumeOpts :: Volume.VolumeOpts + , aoAlsaCtlPath :: Maybe FilePath + } + +defaultOpts :: AlsaOpts +defaultOpts = AlsaOpts Volume.defaultOpts Nothing + +alsaCtlOptionName :: String +alsaCtlOptionName = "alsactl" + +options :: [OptDescr (AlsaOpts -> AlsaOpts)] +options = + Option "" [alsaCtlOptionName] (ReqArg (\x o -> + o { aoAlsaCtlPath = Just x }) "") "" + : fmap (fmap modifyVolumeOpts) Volume.options + where + modifyVolumeOpts f o = o { aoVolumeOpts = f (aoVolumeOpts o) } + +parseOpts :: [String] -> IO AlsaOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +parseOptsIncludingMonitorArgs :: [String] -> IO AlsaOpts +parseOptsIncludingMonitorArgs args = + -- Drop generic Monitor args first + case getOpt Permute [] args of + (_, args', _) -> parseOpts args' + +startAlsaPlugin :: String -> String -> [String] -> (String -> IO ()) -> IO () +startAlsaPlugin mixerName controlName args cb = do + opts <- parseOptsIncludingMonitorArgs args + + let run args2 = do + -- Replicating the reparsing logic used by other plugins for now, + -- but it seems the option parsing could be floated out (actually, + -- GHC could in principle do it already since getOpt is pure, but + -- it would have to inline 'runMBD', 'doArgs' and 'parseOpts' to see + -- it, which probably isn't going to happen with the default + -- optimization settings). + opts2 <- io $ parseOpts args2 + Volume.runVolumeWith (aoVolumeOpts opts2) mixerName controlName + + withMonitorWaiter mixerName (aoAlsaCtlPath opts) $ \wait_ -> + runMB args Volume.volumeConfig run wait_ cb + +withMonitorWaiter :: String -> Maybe FilePath -> (IO () -> IO a) -> IO a +withMonitorWaiter mixerName alsaCtlPath cont = do + mvar <- newMVar () + + path <- determineAlsaCtlPath + + bracket (async $ readerThread mvar path) cancel $ \a -> do + + -- Throw on this thread if there's an exception + -- on the reader thread. + link a + + cont $ takeMVar mvar + + where + + readerThread mvar path = + let createProc = (proc "stdbuf" ["-oL", path, "monitor", mixerName]) + {std_out = CreatePipe} + in + withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do + hSetBuffering alsaOut LineBuffering + + forever $ do + c <- hGetChar alsaOut + when (c == '\n') $ + -- This uses 'tryPutMVar' because 'putMVar' would make 'runVolume' run + -- once for each event. But we want it to run only once after a burst + -- of events. + void $ tryPutMVar mvar () + + defaultPath = "/usr/sbin/alsactl" + + determineAlsaCtlPath = + case alsaCtlPath of + Just path -> do + found <- doesFileExist path + if found + then pure path + else throwIO . ErrorCall $ + "Specified alsactl file " ++ path ++ " does not exist" + + Nothing -> do + (ec, path, err) <- readProcessWithExitCode "which" ["alsactl"] "" + unless (null err) $ hPutStrLn stderr err + case ec of + ExitSuccess -> pure $ trimTrailingNewline path + ExitFailure _ -> do + found <- doesFileExist defaultPath + if found + then pure defaultPath + else throwIO . ErrorCall $ + "alsactl not found in PATH or at " ++ + show defaultPath ++ + "; please specify with --" ++ + alsaCtlOptionName ++ "=/path/to/alsactl" + + +-- This is necessarily very inefficient on 'String's +trimTrailingNewline :: String -> String +trimTrailingNewline x = + case reverse x of + '\n' : '\r' : y -> reverse y + '\n' : y -> reverse y + _ -> x diff --git a/src/Xmobar/Plugins/Monitors/Batt.hs b/src/Xmobar/Plugins/Monitors/Batt.hs new file mode 100644 --- /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 --- /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 --- /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 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Common.hs @@ -0,0 +1,545 @@ +----------------------------------------------------------------------------- +-- | +-- 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.Run.Commands + +-- $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 --- /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 --- /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 --- /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 --- /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 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Disk.hs @@ -0,0 +1,241 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Disk +-- Copyright : (c) 2010, 2011, 2012, 2014, 2018 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.System.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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /dev/null +++ b/src/Xmobar/Plugins/PipeReader.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- 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(PipeReader(..)) where + +import System.IO +import Xmobar.Run.Commands(Exec(..)) +import Xmobar.System.Utils(hGetLineSafe) +import Xmobar.System.Environment(expandEnv) +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 --- /dev/null +++ b/src/Xmobar/Plugins/StdinReader.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- 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.Run.Commands +import Xmobar.X11.Actions (stripActions) +import Xmobar.System.Utils (hGetLineSafe) + +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/XMonadLog.hs b/src/Xmobar/Plugins/XMonadLog.hs new file mode 100644 --- /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.Run.Commands +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar) +import Xmobar.X11.Events (nextEvent') +import Xmobar.X11.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/Run/Commands.hs b/src/Xmobar/Run/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Run/Commands.hs @@ -0,0 +1,82 @@ +----------------------------------------------------------------------------- +-- | +-- 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.Run.Commands (Command (..), Exec (..), tenthSeconds) where + +import Prelude +import Control.Exception (handle, SomeException(..)) +import Data.Char +import System.Process +import System.Exit +import System.IO (hClose) +import Control.Concurrent + +import Xmobar.System.Signal +import Xmobar.System.Utils (hGetLineSafe) + +-- | 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 + +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 diff --git a/src/Xmobar/Run/Runnable.hs b/src/Xmobar/Run/Runnable.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Run/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.Run.Runnable where + +import Control.Monad +import Text.Read +import Xmobar.Run.Types (runnableTypes) +import Xmobar.Run.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/Run/Runnable.hs-boot b/src/Xmobar/Run/Runnable.hs-boot new file mode 100644 --- /dev/null +++ b/src/Xmobar/Run/Runnable.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Xmobar.Run.Runnable where +import Xmobar.Run.Commands + +data Runnable = forall r . (Exec r,Read r,Show r) => Run r + +instance Read Runnable +instance Exec Runnable diff --git a/src/Xmobar/Run/Template.hs b/src/Xmobar/Run/Template.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Run/Template.hs @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Template +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sun Nov 25, 2018 05:49 +-- +-- +-- Handling the top-level output template +-- +------------------------------------------------------------------------------ + + +module Xmobar.Run.Template(parseTemplate, splitTemplate) where + +import qualified Data.Map as Map +import Text.ParserCombinators.Parsec + +import Xmobar.Run.Commands +import Xmobar.Run.Runnable + +defaultAlign :: String +defaultAlign = "}{" + +allTillSep :: String -> Parser String +allTillSep = many . noneOf + +-- | Parses the output template string +templateStringParser :: String -> Parser (String,String,String) +templateStringParser sepChar = do + s <- allTillSep sepChar + com <- templateCommandParser sepChar + ss <- allTillSep sepChar + return (com, s, ss) + +-- | Parses the command part of the template string +templateCommandParser :: String -> Parser String +templateCommandParser sepChar = + let chr = char (head sepChar) in between chr chr (allTillSep sepChar) + +-- | Combines the template parsers +templateParser :: String -> Parser [(String,String,String)] +templateParser s = many $ templateStringParser s + +-- | Actually runs the template parsers over a (segment of) a template +-- string, returning a list of runnables with their prefix and suffix. +parseTemplate :: [Runnable] -> String -> String -> IO [(Runnable,String,String)] +parseTemplate c sepChar s = + do str <- case parse (templateParser sepChar) "" s of + Left _ -> return [("", s, "")] + Right x -> return x + let cl = map alias c + m = Map.fromList $ zip cl c + return $ combine c m str + +-- | Given a finite "Map" and a parsed template produce the resulting +-- output string. +combine :: [Runnable] -> 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 + +-- | Given an two-char alignment separator and a template string, +-- splits it into its segments, that can then be parsed via parseCommands +splitTemplate :: String -> String -> [String] +splitTemplate alignSep template = + case break (==l) template of + (le,_:re) -> case break (==r) re of + (ce,_:ri) -> [le, ce, ri] + _ -> def + _ -> def + where [l, r] = if length alignSep == 2 then alignSep else defaultAlign + def = [template, "", ""] diff --git a/src/Xmobar/Run/Types.hs b/src/Xmobar/Run/Types.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/Run/Types.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TypeOperators, CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Run.Types +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sun Nov 25, 2018 07:17 +-- +-- +-- An enumeration of all runnable types +-- +------------------------------------------------------------------------------ + + +module Xmobar.Run.Types(runnableTypes) where + +import Xmobar.Run.Commands + +import {-# SOURCE #-} Xmobar.Run.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 + +-- | 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/System/DBus.hs b/src/Xmobar/System/DBus.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/System/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.System.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.System.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/System/Environment.hs b/src/Xmobar/System/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/System/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.System.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/System/Kbd.hsc b/src/Xmobar/System/Kbd.hsc new file mode 100644 --- /dev/null +++ b/src/Xmobar/System/Kbd.hsc @@ -0,0 +1,321 @@ +{-# 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.System.Kbd where + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +import Graphics.X11.Xlib + +#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)] + +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!" diff --git a/src/Xmobar/System/Localize.hsc b/src/Xmobar/System/Localize.hsc new file mode 100644 --- /dev/null +++ b/src/Xmobar/System/Localize.hsc @@ -0,0 +1,89 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Localize +-- Copyright : (C) 2011, 2018 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.System.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/System/Signal.hs b/src/Xmobar/System/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/System/Signal.hs @@ -0,0 +1,134 @@ +{-# 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.System.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 + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + +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/System/StatFS.hsc b/src/Xmobar/System/StatFS.hsc new file mode 100644 --- /dev/null +++ b/src/Xmobar/System/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.System.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/System/Utils.hs b/src/Xmobar/System/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/System/Utils.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Utils +-- Copyright: (c) 2010, 2018 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.System.Utils (expandHome, changeLoop, hGetLineSafe) +where + +import Control.Monad +import Control.Concurrent.STM + +import System.Environment +import System.FilePath +import System.IO + +#if defined XFT || defined UTF8 +import qualified System.IO as S (hGetLine) +#endif + +hGetLineSafe :: Handle -> IO String +#if defined XFT || defined UTF8 +hGetLineSafe = S.hGetLine +#else +hGetLineSafe = hGetLine +#endif + + +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) diff --git a/src/Xmobar/X11/Actions.hs b/src/Xmobar/X11/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/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.X11.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/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/Bitmap.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : X11.Bitmap +-- Copyright : (C) 2013, 2015, 2017, 2018 Alexander Polakov +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.X11.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.X11.ColorCache +import Xmobar.X11.Parsers (Widget(..)) +import Xmobar.X11.Actions (Action) + +#ifdef XPM +import Xmobar.X11.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/X11/ColorCache.hs b/src/Xmobar/X11/ColorCache.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/ColorCache.hs @@ -0,0 +1,111 @@ +{-# 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.X11.ColorCache(withColors, withDrawingColors) where + +import Xmobar.X11.MinXft + +#else + +module Xmobar.X11.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/X11/Draw.hs b/src/Xmobar/X11/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/Draw.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.X11.Draw +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sat Nov 24, 2018 18:49 +-- +-- +-- Drawing the xmobar contents +-- +------------------------------------------------------------------------------ + + +module Xmobar.X11.Draw (drawInWin) where + +import Prelude hiding (lookup) +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad (when) +import Control.Arrow ((&&&)) +import Data.Map hiding (foldr, map, filter) + +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras + +import Xmobar.Config.Types +import qualified Xmobar.X11.Bitmap as B +import Xmobar.X11.Actions (Action(..)) +import Xmobar.X11.Types +import Xmobar.X11.Text +import Xmobar.X11.ColorCache +import Xmobar.X11.Window (drawBorder) +import Xmobar.X11.Parsers (Widget(..)) + +#ifdef XFT +import Xmobar.X11.MinXft +import Graphics.X11.Xrender +#endif + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +-- | Draws in and updates the window +drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X () +drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do + r <- ask + let (c,d) = (config &&& display) r + (w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r + strLn = liftIO . mapM getWidth + iconW i = maybe 0 B.width (lookup i $ iconS r) + getWidth (Text s,cl,i,_) = + textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw) + getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) + + p <- liftIO $ createPixmap d w wid ht + (defaultDepthOfScreen (defaultScreenOfDisplay d)) +#if XFT + when (alpha c /= 255) (liftIO $ drawBackground d p (bgColor c) (alpha c) wr) +#endif + withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do + gc <- liftIO $ createGC d w +#if XFT + when (alpha c == 255) $ do +#else + do +#endif + liftIO $ setForeground d gc bgcolor + liftIO $ fillRectangle d p gc 0 0 wid ht + -- write to the pixmap the new string + printStrings p gc fs vs 1 L =<< strLn left + printStrings p gc fs vs 1 R =<< strLn right + printStrings p gc fs vs 1 C =<< strLn center + -- draw border if requested + liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht + -- copy the pixmap with the new string to the window + liftIO $ copyArea d p w gc 0 0 wid ht 0 0 + -- free up everything (we do not want to leak memory!) + liftIO $ freeGC d gc + liftIO $ freePixmap d p + -- resync + liftIO $ sync d True + +verticalOffset :: (Integral b, Integral a, MonadIO m) => + a -> Widget -> XFont -> Int -> Config -> m b +verticalOffset ht (Text t) fontst voffs _ + | voffs > -1 = return $ fi voffs + | otherwise = do + (as,ds) <- liftIO $ textExtents fontst t + let margin = (fi ht - fi ds - fi as) `div` 2 + return $ fi as + margin - 1 +verticalOffset ht (Icon _) _ _ conf + | iconOffset conf > -1 = return $ fi (iconOffset conf) + | otherwise = return $ fi (ht `div` 2) - 1 + +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') + liftIO $ 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 + +-- | An easy way to print the stuff we need to print +printStrings :: Drawable -> GC -> [XFont] -> [Int] -> Position + -> Align -> [(Widget, String, Int, Position)] -> X () +printStrings _ _ _ _ _ _ [] = return () +printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do + r <- ask + let (conf,d) = (config &&& display) r + alph = alpha conf + Rectangle _ _ wid ht = rect r + totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl + remWidth = fi wid - fi totSLen + fontst = fontlist !! i + offset = case a of + C -> (remWidth + offs) `div` 2 + R -> remWidth + L -> offs + (fc,bc) = case break (==',') c of + (f,',':b) -> (f, b ) + (f, _) -> (f, bgColor conf) + valign <- verticalOffset ht s (head fontlist) (voffs !! i) conf + case s of + (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph + (Icon p) -> liftIO $ maybe (return ()) + (B.drawBitmap d dr gc fc bc offset valign) + (lookup p (iconS r)) + printStrings dr gc fontlist voffs (offs + l) a xs diff --git a/src/Xmobar/X11/Events.hs b/src/Xmobar/X11/Events.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/Events.hs @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.X11.Events +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sun Nov 25, 2018 23:24 +-- +-- +-- Utilities or event handling +-- +------------------------------------------------------------------------------ + + +module Xmobar.X11.Events(nextEvent') where + +import Control.Concurrent +import System.Posix.Types (Fd(..)) + +import Graphics.X11.Xlib ( + Display(..), XEventPtr, nextEvent, pending, connectionNumber) + +-- | 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 diff --git a/src/Xmobar/X11/MinXft.hsc b/src/Xmobar/X11/MinXft.hsc new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/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.X11.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/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/Parsers.hs @@ -0,0 +1,146 @@ +{-# 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 +-- +-- Parsing for template substrings +-- +----------------------------------------------------------------------------- + +module Xmobar.X11.Parsers (parseString, Widget(..)) where + +import Xmobar.Config.Types +import Xmobar.X11.Actions + +import Control.Monad (guard, mzero) +import Text.ParserCombinators.Parsec +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 '#') diff --git a/src/Xmobar/X11/Text.hs b/src/Xmobar/X11/Text.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/Text.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.X11.Text +-- 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.X11.Text + ( XFont(..) + , initFont + , initCoreFont + , initUtf8Font + , textExtents + , textWidth + ) where + +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 ) + +#if defined XFT +import Xmobar.X11.MinXft +import Graphics.X11.Xrender +#else +import System.IO(hPutStrLn, stderr) +#endif + +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 + fmap Utf8 $ initUtf8Font d s + +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 + (_,_,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 + 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 $ fromIntegral $ wcTextEscapement fs s +textWidth _ (Core fs) s = return $ fromIntegral $ 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 = fromIntegral $ - (rect_y rl) + descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl) + return (ascent, descent) +#ifdef XFT +textExtents (Xft xftfonts) _ = do + ascent <- fromIntegral `fmap` xft_ascent' xftfonts + descent <- fromIntegral `fmap` xft_descent' xftfonts + return (ascent, descent) +#endif diff --git a/src/Xmobar/X11/Types.hs b/src/Xmobar/X11/Types.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/Types.hs @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Types +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sat Nov 24, 2018 19:02 +-- +-- +-- The Xmobar basic type +-- +------------------------------------------------------------------------------ + + +module Xmobar.X11.Types (X, XConf (..)) where + +import Graphics.X11.Xlib +import Control.Monad.Reader +import Data.Map + +import Xmobar.X11.Bitmap +import Xmobar.X11.Text +import Xmobar.Config.Types + +-- | The X type is a ReaderT +type X = ReaderT XConf IO + +-- | The ReaderT inner component +data XConf = + XConf { display :: Display + , rect :: Rectangle + , window :: Window + , fontListS :: [XFont] + , verticalOffsets :: [Int] + , iconS :: Map FilePath Bitmap + , config :: Config + } diff --git a/src/Xmobar/X11/Window.hs b/src/Xmobar/X11/Window.hs new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/Window.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------------- +-- | +-- 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.X11.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.Types +import Xmobar.X11.Text + +-- $window + +-- | 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 + +-- | 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 (fromIntegral 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 (fromIntegral ht) + moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) + setStruts r c d win srs + return r + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +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/X11/XPMFile.hsc b/src/Xmobar/X11/XPMFile.hsc new file mode 100644 --- /dev/null +++ b/src/Xmobar/X11/XPMFile.hsc @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : XPMFile +-- Copyright : (C) 2014, 2018 Alexander Shabalin +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.X11.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/test/Xmobar/Plugins/Monitors/AlsaSpec.hs b/test/Xmobar/Plugins/Monitors/AlsaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Xmobar/Plugins/Monitors/AlsaSpec.hs @@ -0,0 +1,158 @@ +{-# OPTIONS_GHC -Wall #-} +module Xmobar.Plugins.Monitors.AlsaSpec + ( main + , spec + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import System.FilePath +import System.IO +import System.IO.Temp +import System.Posix.Files +import System.Process +import Test.Hspec + +import Xmobar.Plugins.Monitors.Alsa + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Alsa.getWaitMonitor" $ + it "produces the expected timeline (using a fake alsactl)" + runFakeAlsactlTest + + describe "Alsa.parseOptsIncludingMonitorArgs" $ do + it "works with empty args" $ do + opts <- parseOptsIncludingMonitorArgs [] + aoAlsaCtlPath opts `shouldBe` Nothing + + it "parses --alsactl=foo" $ do + opts <- parseOptsIncludingMonitorArgs ["--", "--alsactl=foo"] + aoAlsaCtlPath opts `shouldBe` Just "foo" + + +runFakeAlsactlTest :: Expectation +runFakeAlsactlTest = + withSystemTempDirectory "xmobar-test" $ \tmpDir -> do + + let fifoPath = tmpDir </> "fifo" + fakeAlsactlPath = tmpDir </> "fake-alsactl" + + writeFile fakeAlsactlPath $ + unlines + [ "#!/bin/bash" + , "[[ $1 == monitor ]] || exit 99" + , "exec cat \"$2\"" + ] + + setFileMode fakeAlsactlPath ownerModes + + withFifoWriteHandle fifoPath $ \fifo -> do + + timeline <- newMVar [] :: IO (MVar [TimelineEntry]) + runVolumeCompleted <- newEmptyMVar :: IO (MVar Bool) -- True -> quit + waiterTaskIsRunning <- newEmptyMVar :: IO (MVar ()) + waiterTaskIsWaiting <- newEmptyMVar :: IO (MVar ()) + + withMonitorWaiter fifoPath (Just fakeAlsactlPath) $ \waitFunc -> do + + let addToTimeline e = modifyMVar_ timeline (pure . (e :)) + + emitEvent = do + addToTimeline EventEmitted + hPutStrLn fifo "#17 (2,0,0,Master Playback Volume,0) VALUE" + hFlush fifo + + putNow mv val = do + ok <- tryPutMVar mv val + unless ok $ expectationFailure "Expected the MVar to be empty" + + simulateRunVolumeCompleted = putNow runVolumeCompleted False + + quitWaiter = putNow runVolumeCompleted True + + waiterTaskMain = do + addToTimeline RunVolume + putNow waiterTaskIsRunning () + q <- takeMVar runVolumeCompleted + unless q $ do + addToTimeline Waiting + putNow waiterTaskIsWaiting () + waitFunc + + waiterTaskMain + + delay_ms = threadDelay . (* 1000) + + withAsync waiterTaskMain $ \waiterTask -> do + + takeMVar waiterTaskIsRunning + simulateRunVolumeCompleted + takeMVar waiterTaskIsWaiting + takeMVar waiterTaskIsRunning -- Waiter returns instantly once + simulateRunVolumeCompleted + takeMVar waiterTaskIsWaiting + + emitEvent + takeMVar waiterTaskIsRunning + simulateRunVolumeCompleted + takeMVar waiterTaskIsWaiting + + let iters = 3 + burstSize = 5 + + replicateM_ iters $ do + emitEvent + takeMVar waiterTaskIsRunning + -- Now more events start to accumulate during runVolume + replicateM_ burstSize emitEvent + delay_ms 250 -- Give the events time to go through the pipe + simulateRunVolumeCompleted + -- runVolume completed and should run once more due to + -- accumulated events + takeMVar waiterTaskIsWaiting + takeMVar waiterTaskIsRunning + simulateRunVolumeCompleted + takeMVar waiterTaskIsWaiting + + emitEvent + takeMVar waiterTaskIsRunning + quitWaiter + + wait waiterTask + + timelineValue <- reverse <$> readMVar timeline + + timelineValue `shouldBe` + [RunVolume, Waiting, RunVolume, Waiting, EventEmitted, RunVolume, Waiting] + ++ concat + (replicate iters $ + [EventEmitted, RunVolume] + ++ replicate burstSize EventEmitted + ++ [Waiting, RunVolume, Waiting]) + ++ [EventEmitted, RunVolume] + +data TimelineEntry = EventEmitted | Waiting | RunVolume + deriving(Eq) + +instance Show TimelineEntry where + show x = + case x of + EventEmitted -> "E" + Waiting -> "W" + RunVolume -> "R" + + +withFifoWriteHandle :: FilePath -> (Handle -> IO b) -> IO b +withFifoWriteHandle fifoPath body = do + createNamedPipe fifoPath ownerModes + -- Can't seem to get the writing to the FIFO to work internally + withCreateProcess + (proc "bash" ["-c", "cat >> \"$0\"", fifoPath]) {std_in = CreatePipe} + $ \(Just h) _ _ _ -> do + hSetBuffering h LineBuffering + body h diff --git a/test/Xmobar/Plugins/Monitors/CommonSpec.hs b/test/Xmobar/Plugins/Monitors/CommonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Xmobar/Plugins/Monitors/CommonSpec.hs @@ -0,0 +1,29 @@ +module Xmobar.Plugins.Monitors.CommonSpec + ( main + , spec + ) where + +import Test.Hspec +import Xmobar.Plugins.Monitors.Common + +main :: IO () +main = hspec spec + +spec :: Spec +spec = + describe "Common.padString" $ do + it "returns given string when called with default values" $ + do padString 0 0 "" False "" "test" `shouldBe` "test" + + it "truncates to max width" $ do + let maxw = 3 + givenStr = "mylongstr" + expectedStr = take maxw givenStr + padString 0 maxw "" False "" givenStr `shouldBe` expectedStr + + it "truncates to max width and concatenate with ellipsis" $ do + let maxw = 3 + givenStr = "mylongstr" + ellipsis = "..." + expectedStr = (++ ellipsis) . take 3 $ givenStr + padString 0 maxw "" False ellipsis givenStr `shouldBe` expectedStr diff --git a/xmobar.cabal b/xmobar.cabal --- a/xmobar.cabal +++ b/xmobar.cabal @@ -1,5 +1,5 @@ name: xmobar -version: 0.28.1 +version: 0.29 homepage: http://xmobar.org synopsis: A Minimalistic Text Based Status Bar description: Xmobar is a minimalistic text based status bar. @@ -17,52 +17,10 @@ build-type: Simple extra-source-files: readme.md, changelog.md, - samples/xmobar.config, samples/xmonadpropwrite.hs - samples/Plugins/helloworld.config, - samples/Plugins/HelloWorld.hs - -test-suite XmobarTest - type: exitcode-stdio-1.0 - hs-source-dirs: - src, - test - main-is: Spec.hs - other-modules: - Xmobar, Actions, Bitmap, Config, Parsers, Commands, Localize, - XUtil, StatFS, Runnable, ColorCache, Window, Signal, - Environment, Paths_xmobar, - Plugins, Plugins.BufferedPipeReader, - Plugins.CommandReader, Plugins.Date, Plugins.EWMH, - Plugins.PipeReader, Plugins.MarqueePipeReader, - Plugins.StdinReader, Plugins.XMonadLog, - Plugins.Utils, Plugins.Kbd, Plugins.Locks, Plugins.Monitors, - Plugins.Monitors.Batt, Plugins.Monitors.Common, - Plugins.Monitors.CoreCommon, Plugins.Monitors.CoreTemp, - Plugins.Monitors.CpuFreq, Plugins.Monitors.Cpu, - Plugins.Monitors.Disk, Plugins.Monitors.Mem, - Plugins.Monitors.MultiCpu, Plugins.Monitors.Net, - Plugins.Monitors.Swap, Plugins.Monitors.Thermal, - Plugins.Monitors.ThermalZone, Plugins.Monitors.Top, - Plugins.Monitors.Uptime, - Plugins.Monitors.Bright, Plugins.Monitors.CatInt - build-depends: - base >= 4.9.1.0 && < 4.13, - hspec == 2.*, - containers, - regex-compat, - process, - old-locale, - bytestring, - directory, - unix, - time, - filepath, - transformers, - X11 >= 1.6.1, - mtl >= 2.1 && < 2.3, - parsec == 3.1.*, - parsec-numbers == 0.1.0, - stm >= 2.3 && < 2.6 + examples/padding-icon.sh, + examples/xmobar.config, examples/xmonadpropwrite.hs + examples/Plugins/helloworld.config, + examples/Plugins/HelloWorld.hs source-repository head type: git @@ -110,7 +68,7 @@ default: False flag with_xpm - description: Enable usage of xpm for icons + description: Enable usage of xpm for icons. default: False flag with_threaded @@ -118,7 +76,7 @@ default: False flag with_rtsopts - description: Use -with-rtsopts=-V0 to reduce wakeups + description: Use -with-rtsopts=-V0 to reduce wakeups. default: True flag with_uvmeter @@ -126,38 +84,78 @@ default: False flag with_weather - description: Enable weather plugin + description: Enable weather plugin. default: True flag with_conduit - description: Use http-conduits for getting weather data, only has an effect if with_weather is set. + description: Use http-conduits for weather data, used only if with_weather. default: False -executable xmobar - hs-source-dirs: src - main-is: Main.hs - other-modules: - Xmobar, Actions, Bitmap, Config, Parsers, Commands, Localize, - XUtil, StatFS, Runnable, ColorCache, Window, Signal, - Environment, Paths_xmobar, - Plugins, Plugins.BufferedPipeReader, - Plugins.CommandReader, Plugins.Date, Plugins.EWMH, - Plugins.PipeReader, Plugins.MarqueePipeReader, - Plugins.StdinReader, Plugins.XMonadLog, - Plugins.Utils, Plugins.Kbd, Plugins.Locks, Plugins.Monitors, - Plugins.Monitors.Batt, Plugins.Monitors.Common, - Plugins.Monitors.CoreCommon, Plugins.Monitors.CoreTemp, - Plugins.Monitors.CpuFreq, Plugins.Monitors.Cpu, - Plugins.Monitors.Disk, Plugins.Monitors.Mem, - Plugins.Monitors.MultiCpu, Plugins.Monitors.Net, - Plugins.Monitors.Swap, Plugins.Monitors.Thermal, - Plugins.Monitors.ThermalZone, Plugins.Monitors.Top, - Plugins.Monitors.Uptime, - Plugins.Monitors.Bright, Plugins.Monitors.CatInt +library + hs-source-dirs: src - ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind + exposed-modules: Xmobar + + other-modules: Paths_xmobar, + Xmobar.Config.Types, + Xmobar.Config.Parse, + Xmobar.Run.Types, + Xmobar.Run.Template, + Xmobar.Run.Commands, + Xmobar.Run.Runnable + Xmobar.App.EventLoop, + Xmobar.App.Config, + Xmobar.App.Main, + Xmobar.App.Opts, + Xmobar.App.Compile, + Xmobar.System.Utils, + Xmobar.System.StatFS, + Xmobar.System.Environment, + Xmobar.System.Localize, + Xmobar.System.Signal, + Xmobar.System.Kbd, + Xmobar.X11.Actions, + Xmobar.X11.Events, + Xmobar.X11.Parsers, + Xmobar.X11.Types, + Xmobar.X11.Text, + Xmobar.X11.Bitmap, + Xmobar.X11.ColorCache, + Xmobar.X11.Window, + Xmobar.X11.Draw, + Xmobar.Plugins.BufferedPipeReader, + Xmobar.Plugins.CommandReader, + Xmobar.Plugins.Date, + Xmobar.Plugins.EWMH, + Xmobar.Plugins.PipeReader, + Xmobar.Plugins.MarqueePipeReader, + Xmobar.Plugins.StdinReader, + Xmobar.Plugins.XMonadLog, + Xmobar.Plugins.Kbd, + Xmobar.Plugins.Locks, + Xmobar.Plugins.Monitors, + Xmobar.Plugins.Monitors.Batt, + Xmobar.Plugins.Monitors.Common, + Xmobar.Plugins.Monitors.CoreCommon, + Xmobar.Plugins.Monitors.CoreTemp, + Xmobar.Plugins.Monitors.CpuFreq, + Xmobar.Plugins.Monitors.Cpu, + Xmobar.Plugins.Monitors.Disk, + Xmobar.Plugins.Monitors.Mem, + Xmobar.Plugins.Monitors.MultiCpu, + Xmobar.Plugins.Monitors.Net, + Xmobar.Plugins.Monitors.Swap, + Xmobar.Plugins.Monitors.Thermal, + Xmobar.Plugins.Monitors.ThermalZone, + Xmobar.Plugins.Monitors.Top, + Xmobar.Plugins.Monitors.Uptime, + Xmobar.Plugins.Monitors.Bright, + Xmobar.Plugins.Monitors.CatInt + extra-libraries: Xrandr Xrender + ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind + build-depends: base >= 4.9.1.0 && < 4.13, containers, @@ -174,7 +172,9 @@ mtl >= 2.1 && < 2.3, parsec == 3.1.*, parsec-numbers >= 0.1.0, - stm >= 2.3 && < 2.6 + stm >= 2.3 && < 2.6, + extensible-exceptions == 0.1.*, + async if impl(ghc < 8.0.2) -- Disable building with GHC before 8.0.2. @@ -187,15 +187,14 @@ -- -threaded is a workaround for 100% CPU busy loop -- (http://hackage.haskell.org/trac/ghc/ticket/4934). -- See also comments in https://github.com/jaor/xmobar/pull/36 - ghc-options: -threaded cpp-options: -DTHREADED_RUNTIME if flag(with_rtsopts) - ghc-options: -with-rtsopts=-V0 + cpp-options: -DRTSOPTS if flag(with_xft) || flag(all_extensions) build-depends: utf8-string >= 0.3 && < 1.1, X11-xft >= 0.2 && < 0.4 - other-modules: MinXft + other-modules: Xmobar.X11.MinXft cpp-options: -DXFT if flag(with_utf8) || flag(all_extensions) @@ -204,49 +203,51 @@ if flag(with_inotify) || flag(all_extensions) build-depends: hinotify >= 0.3 && < 0.5 - other-modules: Plugins.Mail, Plugins.MBox + exposed-modules: Xmobar.Plugins.Mail, Xmobar.Plugins.MBox cpp-options: -DINOTIFY if flag(with_iwlib) || flag(all_extensions) extra-libraries: iw build-depends: iwlib >= 0.1.0 && < 0.2 - other-modules: Plugins.Monitors.Wireless + exposed-modules: Xmobar.Plugins.Monitors.Wireless cpp-options: -DIWLIB if flag(with_mpd) || flag(all_extensions) build-depends: libmpd >= 0.9.0.6 - other-modules: Plugins.Monitors.MPD + exposed-modules: Xmobar.Plugins.Monitors.MPD cpp-options: -DLIBMPD if flag(with_alsa) || flag(all_extensions) build-depends: alsa-mixer > 0.2.0.2 - build-depends: alsa-core == 0.5.* - other-modules: Plugins.Monitors.Volume + build-depends: alsa-core == 0.5.*, + process >= 1.4.3.0 + exposed-modules: Xmobar.Plugins.Monitors.Volume + Xmobar.Plugins.Monitors.Alsa cpp-options: -DALSA if flag(with_datezone) || flag(all_extensions) build-depends: timezone-olson == 0.1.*, timezone-series == 0.1.* - other-modules: Plugins.DateZone + exposed-modules: Xmobar.Plugins.DateZone cpp-options: -DDATEZONE if flag(with_mpris) || flag(all_extensions) build-depends: dbus >= 1 - other-modules: Plugins.Monitors.Mpris + exposed-modules: Xmobar.Plugins.Monitors.Mpris cpp-options: -DMPRIS if flag(with_dbus) || flag(all_extensions) build-depends: dbus >= 1 - other-modules: IPC.DBus + other-modules: Xmobar.System.DBus cpp-options: -DDBUS if flag(with_xpm) || flag(all_extensions) extra-libraries: Xpm - other-modules: XPMFile + other-modules: Xmobar.X11.XPMFile cpp-options: -DXPM if flag(with_weather) || flag(all_extensions) build-depends: HTTP >= 4000.2.4 - other-modules: Plugins.Monitors.Weather + exposed-modules: Xmobar.Plugins.Monitors.Weather cpp-options: -DWEATHER if flag(with_conduit) -- use http-conduit instead of simple-http @@ -254,6 +255,72 @@ cpp-options: -DHTTP_CONDUIT if flag(with_uvmeter) && flag(with_conduit) - other-modules: Plugins.Monitors.UVMeter + exposed-modules: Xmobar.Plugins.Monitors.UVMeter build-depends: http-conduit, http-types cpp-options: -DUVMETER + +executable xmobar + hs-source-dirs: app + main-is: Main.hs + build-depends: base, + containers, + async, + X11, + directory, + filepath, + unix, + parsec, + xmobar + + ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind + + if flag(with_rtsopts) + ghc-options: -with-rtsopts=-V0 + + if flag(with_threaded) + -- -threaded is a workaround for 100% CPU busy loop + -- (http://hackage.haskell.org/trac/ghc/ticket/4934). + -- See also comments in https://github.com/jaor/xmobar/pull/36 + ghc-options: -threaded + cpp-options: -DTHREADED_RUNTIME + +test-suite XmobarTest + type: exitcode-stdio-1.0 + hs-source-dirs: src, test + main-is: Spec.hs + build-depends: base, + containers, + regex-compat, + process, + old-locale, + bytestring, + directory, + unix, + time, + filepath, + transformers, + X11, + mtl, + parsec, + parsec-numbers, + stm, + async, + temporary, + hspec == 2.*, + xmobar + + other-modules: Xmobar.Plugins.Monitors.CommonSpec + Xmobar.Plugins.Monitors.Common + Xmobar.System.Signal + Xmobar.System.Utils + Xmobar.Run.Commands + + if flag(with_alsa) || flag(all_extensions) + build-depends: alsa-mixer > 0.2.0.2, + alsa-core == 0.5.*, + process >= 1.4.3.0 + other-modules: Xmobar.Plugins.Monitors.Volume + Xmobar.Plugins.Monitors.Alsa + Xmobar.Plugins.Monitors.AlsaSpec + + cpp-options: -DALSA