packages feed

xmobar 0.28.1 → 0.29

raw patch · 142 files changed

+9047/−7898 lines, 142 filesdep +asyncdep +extensible-exceptionsdep +temporarydep ~X11dep ~basedep ~mtlsetup-changed

Dependencies added: async, extensible-exceptions, temporary, xmobar

Dependency ranges changed: X11, base, mtl, parsec, parsec-numbers, process, stm

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Xmobar.Main+-- Copyright   :  (c) Andrea Rossato+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>+-- Stability   :  unstable+-- Portability :  unportable+--+-- The main module of Xmobar, a text based status bar+--+-----------------------------------------------------------------------------++module Main (main) where++import Xmobar++main :: IO ()+main = xmobarMain
changelog.md view
@@ -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)
+ examples/Plugins/HelloWorld.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Plugins.HelloWorld+-- Copyright   :  (c) Andrea Rossato+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>+-- 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 "<fc=red>Hello World!!</fc>"
+ examples/Plugins/helloworld.config view
@@ -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% | <fc=yellow>%date%</fc>"+       }
+ examples/padding-icon.sh view
@@ -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 <icon>-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} */+/* <w/cols>  <h/rows>  <colors>  <chars per pixel> */+"$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 "<icon=${iconfile}/>"
+ examples/xmobar.config view
@@ -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","<station>: <tempC>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: <usedratio>%"] 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% }\+                    \{ <fc=#ee9a00>%date%</fc>| %EGPF% | %uname%"+       }
+ examples/xmonadpropwrite.hs view
@@ -0,0 +1,41 @@+-- Copyright Spencer Janssen <spencerjanssen@gmail.com>+--           Tomas Janousek <tomi@nomi.cz>+-- 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
readme.md view
@@ -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 <xmobar@projects.haskell.org>+    Mail bug reports and suggestions to <mail@jao.io>  ## 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   <font size="+1">**`XMonadLog`**</font>@@ -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
− samples/Plugins/HelloWorld.hs 
@@ -1,24 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Plugins.HelloWorld--- Copyright   :  (c) Andrea Rossato--- License     :  BSD-style (see LICENSE)------ Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>--- 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 "<fc=red>Hello World!!</fc>"
− samples/Plugins/helloworld.config 
@@ -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% | <fc=yellow>%date%</fc>"-       }
− samples/xmobar.config 
@@ -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","<station>: <tempC>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: <usedratio>%"] 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% }\-                    \{ <fc=#ee9a00>%date%</fc>| %EGPF% | %uname%"-       }
− samples/xmonadpropwrite.hs 
@@ -1,41 +0,0 @@--- Copyright Spencer Janssen <spencerjanssen@gmail.com>---           Tomas Janousek <tomi@nomi.cz>--- 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
− src/Actions.hs 
@@ -1,34 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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>"
− src/Bitmap.hs 
@@ -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
− src/ColorCache.hs 
@@ -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
− src/Commands.hs 
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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
− src/Config.hs 
@@ -1,160 +0,0 @@-{-# LANGUAGE TypeOperators #-}---------------------------------------------------------------------------------- |--- Module      :  Xmobar.Config--- Copyright   :  (c) Andrea Rossato--- License     :  BSD-style (see LICENSE)------ Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>--- Stability   :  unstable--- Portability :  unportable------ The configuration module of Xmobar, a text based status bar-----------------------------------------------------------------------------------module 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% }{ " ++-                        "<fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>"-           }----- | An alias for tuple types that is more convenient for long lists.-type a :*: b = (a, b)-infixr :*:---- | This is the list of types that can be hidden inside--- 'Runnable.Runnable', the existential type that stores all commands--- to be executed by Xmobar. It is used by 'Runnable.readRunnable' in--- the 'Runnable.Runnable' Read instance. To install a plugin just add--- the plugin's type to the list of types (separated by ':*:') appearing in--- this function's type signature.-runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*:-                 BufferedPipeReader :*: CommandReader :*: StdinReader :*:-                 XMonadLog :*: EWMH :*: Kbd :*: Locks :*: Mail :*: MBox :*:-                 DateZone :*: MarqueePipeReader :*: ()-runnableTypes = undefined
− src/Environment.hs 
@@ -1,49 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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
− src/IPC/DBus.hs 
@@ -1,66 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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)
− src/Localize.hsc 
@@ -1,89 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- Module      :  Localize--- Copyright   :  (C) 2011 Martin Perner--- License     :  BSD-style (see LICENSE)------ Maintainer  :  Martin Perner <martin@perner.cc>--- Stability   :  unstable--- Portability :  unportable------ This module provides an interface to locale information e.g. for DateL-----------------------------------------------------------------------------------module 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
− src/Main.hs 
@@ -1,247 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module      :  Xmobar.Main--- Copyright   :  (c) Andrea Rossato--- License     :  BSD-style (see LICENSE)------ Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>--- 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 = "<xmobar@projects.haskell.org>"--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
− src/MinXft.hsc 
@@ -1,333 +0,0 @@---------------------------------------------------------------------------------- |--- 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 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
− src/Parsers.hs 
@@ -1,324 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module      :  Xmobar.Parsers--- Copyright   :  (c) Andrea Rossato--- License     :  BSD-style (see LICENSE)------ Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>--- Stability   :  unstable--- Portability :  unportable------ Parsers needed for Xmobar, a text based status bar-----------------------------------------------------------------------------------module 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 "<raw=" followed by a--- string of digits (base 10) denoting the length of the raw string,--- a literal ":" as digit-string-terminator, the raw string itself, and--- then a literal "/>".-rawParser :: ColorString-          -> FontIndex-          -> Maybe [Action]-          -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]-rawParser c f a = do-  string "<raw="-  lenstr <- many1 digit-  char ':'-  case reads lenstr of-    [(len,[])] -> do-      guard ((len :: Integer) <= fromIntegral (maxBound :: Int))-      s <- count (fromIntegral len) anyChar-      string "/>"-      return [(Text s, c, f, a)]-    _ -> mzero---- | Wrapper for notFollowedBy that returns the result of the first parser.---   Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy---   accepts only parsers with return type Char.-notFollowedBy' :: Parser a -> Parser b -> Parser a-notFollowedBy' p e = do x <- p-                        notFollowedBy $ try (e >> return '*')-                        return x--iconParser :: String -> FontIndex -> Maybe [Action]-              -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]-iconParser c f a = do-  string "<icon="-  i <- manyTill (noneOf ">") (try (string "/>"))-  return [(Icon i, c, f, a)]--actionParser :: String -> FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]-actionParser c f act = do-  string "<action="-  command <- choice [between (char '`') (char '`') (many1 (noneOf "`")),-                   many1 (noneOf ">")]-  buttons <- (char '>' >> return "1") <|> (space >> spaces >>-    between (string "button=") (string ">") (many1 (oneOf "12345")))-  let a = Spawn (toButtons buttons) command-      a' = case act of-        Nothing -> Just [a]-        Just act' -> Just $ a : act'-  s <- manyTill (allParsers c f a') (try $ string "</action>")-  return (concat s)--toButtons :: String -> [Button]-toButtons = map (\x -> read [x])---- | Parsers a string wrapped in a color specification.-colorParser :: FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]-colorParser f a = do-  c <- between (string "<fc=") (string ">") colors-  s <- manyTill (allParsers c f a) (try $ string "</fc>")-  return (concat s)---- | Parsers a string wrapped in a font specification.-fontParser :: ColorString -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]-fontParser c a = do-  f <- between (string "<fn=") (string ">") colors-  s <- manyTill (allParsers c (read f) a) (try $ string "</fn>")-  return (concat s)---- | Parses a color specification (hex or named)-colors :: Parser String-colors = many1 (alphaNum <|> char ',' <|> char '#')---- | Parses the output template string-templateStringParser :: Config -> Parser (String,String,String)-templateStringParser c = do-  s   <- allTillSep c-  com <- templateCommandParser c-  ss  <- allTillSep c-  return (com, s, ss)---- | Parses the command part of the template string-templateCommandParser :: Config -> Parser String-templateCommandParser c =-  let chr = char . head . sepChar-  in  between (chr c) (chr c) (allTillSep c)---- | Combines the template parsers-templateParser :: Config -> Parser [(String,String,String)]-templateParser = many . templateStringParser---- | Actually runs the template parsers-parseTemplate :: Config -> String -> IO [(Runnable,String,String)]-parseTemplate c s =-    do str <- case parse (templateParser c) "" s of-                Left _  -> return [("", s, "")]-                Right x -> return x-       let cl = map alias (commands c)-           m  = Map.fromList $ zip cl (commands c)-       return $ combine c m str---- | Given a finite "Map" and a parsed template produce the resulting--- output string.-combine :: Config -> Map.Map String Runnable-           -> [(String, String, String)] -> [(Runnable,String,String)]-combine _ _ [] = []-combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs-    where com  = Map.findWithDefault dflt ts m-          dflt = Run $ Com ts [] [] 10--allTillSep :: Config -> Parser String-allTillSep = many . noneOf . sepChar--stripComments :: String -> String-stripComments =-  unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines-    where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else ""-          strip m ('"':xs) = '"': strip (not m) xs-          strip m (x:xs) = x : strip m xs-          strip _ [] = []---- | Parse the config, logging a list of fields that were missing and replaced--- by the default definition.-parseConfig :: String -> Either ParseError (Config,[String])-parseConfig = runParser parseConf fields "Config" . stripComments-    where-      parseConf = do-        many space-        sepEndSpc ["Config","{"]-        x <- perms-        eof-        s <- getState-        return (x,s)--      perms = permute $ Config-              <$?> pFont <|?> pFontList <|?> pWmClass <|?> pWmName-              <|?> pBgColor <|?> pFgColor-              <|?> pPosition <|?> pTextOffset <|?> pTextOffsets-              <|?> pIconOffset <|?> pBorder-              <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart-              <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest-              <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot-              <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate---      fields    = [ "font", "additionalFonts","bgColor", "fgColor"-                  , "wmClass", "wmName", "sepChar"-                  , "alignSep" , "border", "borderColor" ,"template"-                  , "position" , "textOffset", "textOffsets", "iconOffset"-                  , "allDesktops", "overrideRedirect", "pickBroadest"-                  , "hideOnStart", "lowerOnStart", "persistent", "iconRoot"-                  , "alpha", "commands"-                  ]--      pFont = strField font "font"-      pFontList = strListField additionalFonts "additionalFonts"-      pWmClass = strField wmClass "wmclass"-      pWmName = strField wmName "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."
− src/Plugins.hs 
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Xmobar.Plugins--- Copyright   :  (c) Andrea Rossato--- License     :  BSD-style (see LICENSE)------ Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>--- Stability   :  unstable--- Portability :  unportable------ This module exports the API for plugins.------ Have a look at Plugins\/HelloWorld.hs-----------------------------------------------------------------------------------module Plugins-    ( Exec (..)-    , tenthSeconds-    , readFileSafe-    , hGetLineSafe-    ) where--import Commands-import XUtil
− src/Plugins/BufferedPipeReader.hs 
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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
− src/Plugins/CommandReader.hs 
@@ -1,39 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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"
− src/Plugins/Date.hs 
@@ -1,38 +0,0 @@-{-# 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 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
− src/Plugins/DateZone.hs 
@@ -1,85 +0,0 @@-{-# 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 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
− src/Plugins/EWMH.hs 
@@ -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 <spencerjanssen@gmail.com>--- 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 ["<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
− src/Plugins/Kbd.hsc 
@@ -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 <martin@perner.cc>--- 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 <X11/XKBlib.h>-#include <X11/extensions/XKB.h>-#include <X11/extensions/XKBstr.h>------- Definition for XkbStaceRec and getKbdLayout taken from--- XMonad.Layout.XKBLayout----data XkbStateRec = XkbStateRec {-    group :: CUChar,-    locked_group :: CUChar,-    base_group :: CUShort,-    latched_group :: CUShort,-    mods :: CUChar,-    base_mods :: CUChar,-    latched_mods :: CUChar,-    locked_mods :: CUChar,-    compat_state :: CUChar,-    grab_mods :: CUChar,-    compat_grab_mods :: CUChar,-    lookup_mods :: CUChar,-    compat_lookup_mods :: CUChar,-    ptr_buttons :: CUShort-}--instance Storable XkbStateRec where-    sizeOf _ = (#size XkbStateRec)-    alignment _ = alignment (undefined :: CUShort)-    poke _ _ = undefined-    peek ptr = do-        r_group <- (#peek XkbStateRec, group) ptr-        r_locked_group <- (#peek XkbStateRec, locked_group) ptr-        r_base_group <- (#peek XkbStateRec, base_group) ptr-        r_latched_group <- (#peek XkbStateRec, latched_group) ptr-        r_mods <- (#peek XkbStateRec, mods) ptr-        r_base_mods <- (#peek XkbStateRec, base_mods) ptr-        r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr-        r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr-        r_compat_state <- (#peek XkbStateRec, compat_state) ptr-        r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr-        r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr-        r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr-        r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr-        r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr-        return XkbStateRec {-            group = r_group,-            locked_group = r_locked_group,-            base_group = r_base_group,-            latched_group = r_latched_group,-            mods = r_mods,-            base_mods = r_base_mods,-            latched_mods = r_latched_mods,-            locked_mods = r_locked_mods,-            compat_state = r_compat_state,-            grab_mods = r_grab_mods,-            compat_grab_mods = r_compat_grab_mods,-            lookup_mods = r_lookup_mods,-            compat_lookup_mods = r_compat_lookup_mods,-            ptr_buttons = r_ptr_buttons-        }--foreign import ccall unsafe "X11/XKBlib.h XkbGetState"-    xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt---getKbdLayout :: Display -> IO Int-getKbdLayout d = alloca $ \stRecPtr -> do-    xkbGetState d 0x100 stRecPtr-    st <- peek stRecPtr-    return $ fromIntegral (group st)------------data XkbKeyNameRec = XkbKeyNameRec {-    name :: Ptr CChar -- array-}------- the t_ before alias is just because of name collisions----data XkbKeyAliasRec = XkbKeyAliasRec {-    real  :: Ptr CChar, -- array-    t_alias :: Ptr CChar  -- array-}------- the t_ before geometry is just because of name collisions----data XkbNamesRec = XkbNamesRec {-    keycodes :: Atom,-    t_geometry :: Atom,-    symbols :: Atom,-    types :: Atom,-    compat :: Atom,-    vmods :: Ptr Atom,-    indicators :: Ptr Atom, -- array-    groups :: Ptr Atom, -- array-    keys :: Ptr XkbKeyNameRec,-    key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec,-    radio_groups :: Ptr Atom,-    phys_symbols :: Atom,-    num_keys :: CUChar,-    num_key_aliases :: CUChar,-    num_rg :: CUShort-}------- the t_ before map, indicators and compat are just because of name collisions----data XkbDescRec = XkbDescRec {-    t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care-    flags :: CUShort,-    device_spec :: CUShort,-    min_key_code :: KeyCode,-    max_key_code :: KeyCode,-    ctrls :: Ptr CChar, -- XkbControlsPtr ;  dont' care-    server :: Ptr CChar, -- XkbServerMapPtr ;  dont' care-    t_map :: Ptr CChar, --XkbClientMapPtr ;  dont' care-    t_indicators :: Ptr CChar, -- XkbIndicatorPtr ;  dont' care-    names :: Ptr XkbNamesRec, -- array-    t_compat :: Ptr CChar, -- XkbCompatMap ;  dont' care-    geom :: Ptr CChar -- XkbGeometryPtr ;  dont' care--}--instance Storable XkbKeyNameRec where-    sizeOf _ = (#size XkbKeyNameRec)-    alignment _ = alignment (undefined :: CUShort)-    poke _ _ = undefined-    peek ptr = do-        r_name <- (#peek XkbKeyNameRec, name) ptr--        return XkbKeyNameRec {-            name = r_name-        }--instance Storable XkbKeyAliasRec where-    sizeOf _ = (#size XkbKeyAliasRec)-    alignment _ = alignment (undefined :: CUShort)-    poke _ _ = undefined-    peek ptr = do-        r_real <- (#peek XkbKeyAliasRec, real) ptr-        r_alias <- (#peek XkbKeyAliasRec, alias) ptr--        return XkbKeyAliasRec {-            real = r_real,-            t_alias = r_alias-        }--instance Storable XkbNamesRec where-    sizeOf _ = (#size XkbNamesRec)-    alignment _ = alignment (undefined :: CUShort)-    poke _ _ = undefined-    peek ptr = do-        r_keycodes <- (#peek XkbNamesRec, keycodes) ptr-        r_geometry <- (#peek XkbNamesRec, geometry) ptr-        r_symbols <- (#peek XkbNamesRec, symbols ) ptr-        r_types <- (#peek XkbNamesRec, types ) ptr-        r_compat <- (#peek XkbNamesRec, compat ) ptr-        r_vmods <- (#peek XkbNamesRec,  vmods ) ptr-        r_indicators <- (#peek XkbNamesRec, indicators ) ptr-        r_groups <- (#peek XkbNamesRec, groups ) ptr-        r_keys <- (#peek XkbNamesRec, keys ) ptr-        r_key_aliases <- (#peek XkbNamesRec, key_aliases  ) ptr-        r_radio_groups <- (#peek XkbNamesRec, radio_groups  ) ptr-        r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr-        r_num_keys <- (#peek XkbNamesRec,num_keys  ) ptr-        r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases  ) ptr-        r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr--        return XkbNamesRec {-            keycodes = r_keycodes,-            t_geometry = r_geometry,-            symbols = r_symbols,-            types = r_types,-            compat = r_compat,-            vmods = r_vmods,-            indicators = r_indicators,-            groups = r_groups,-            keys = r_keys,-            key_aliases = r_key_aliases,-            radio_groups = r_radio_groups,-            phys_symbols = r_phys_symbols,-            num_keys = r_num_keys,-            num_key_aliases = r_num_key_aliases,-            num_rg = r_num_rg-       }--instance Storable XkbDescRec where-    sizeOf _ = (#size XkbDescRec)-    alignment _ = alignment (undefined :: CUShort)-    poke _ _ = undefined-    peek ptr = do-        r_dpy <- (#peek XkbDescRec, dpy) ptr-        r_flags <- (#peek XkbDescRec, flags) ptr-        r_device_spec <- (#peek XkbDescRec, device_spec) ptr-        r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr-        r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr-        r_ctrls <- (#peek XkbDescRec, ctrls) ptr-        r_server <- (#peek XkbDescRec, server) ptr-        r_map <- (#peek XkbDescRec, map) ptr-        r_indicators <- (#peek XkbDescRec, indicators) ptr-        r_names <- (#peek XkbDescRec, names) ptr-        r_compat <- (#peek XkbDescRec, compat) ptr-        r_geom <- (#peek XkbDescRec, geom) ptr--        return XkbDescRec {-            t_dpy = r_dpy,-            flags = r_flags,-            device_spec = r_device_spec,-            min_key_code = r_min_key_code,-            max_key_code = r_max_key_code,-            ctrls = r_ctrls,-            server = r_server,-            t_map = r_map,-            t_indicators = r_indicators,-            names = r_names,-            t_compat = r_compat,-            geom = r_geom-        }------- C bindings-----foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard"-    xkbAllocKeyboard :: IO (Ptr XkbDescRec)--foreign import ccall unsafe "X11/XKBlib.h XkbGetNames"-    xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec)  -> IO Status--foreign import ccall unsafe "X11/XKBlib.h XGetAtomName"-    xGetAtomName :: Display -> Atom -> IO CString--foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames"-    xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()--foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard"-    xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()--foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails"-    xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt--foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents"-    xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt---xkbUseCoreKbd :: CUInt-xkbUseCoreKbd = #const XkbUseCoreKbd--xkbStateNotify :: CUInt-xkbStateNotify = #const XkbStateNotify--xkbIndicatorStateNotify :: CUInt-xkbIndicatorStateNotify = #const XkbIndicatorStateNotify--xkbMapNotify :: CUInt-xkbMapNotify = #const XkbMapNotify--xkbMapNotifyMask :: CUInt-xkbMapNotifyMask = #const XkbMapNotifyMask--xkbNewKeyboardNotifyMask :: CUInt-xkbNewKeyboardNotifyMask  = #const XkbNewKeyboardNotifyMask--xkbAllStateComponentsMask :: CULong-xkbAllStateComponentsMask = #const XkbAllStateComponentsMask--xkbGroupStateMask :: CULong-xkbGroupStateMask = #const XkbGroupStateMask--xkbSymbolsNameMask :: CUInt-xkbSymbolsNameMask = #const XkbSymbolsNameMask--xkbGroupNamesMask :: CUInt-xkbGroupNamesMask = #const XkbGroupNamesMask--type KbdOpts = [(String, String)]---- gets the layout string-getLayoutStr :: Display -> IO String-getLayoutStr dpy =  do-        kbdDescPtr <- xkbAllocKeyboard-        status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr-        str <- getLayoutStr' status dpy kbdDescPtr-        xkbFreeNames kbdDescPtr xkbGroupNamesMask 1-        xkbFreeKeyboard kbdDescPtr 0 1-        return str--getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String-getLayoutStr' st dpy kbdDescPtr =-        if st == 0 then -- Success-            do-            kbdDesc <- peek kbdDescPtr-            nameArray <- peek (names kbdDesc)-            atom <- xGetAtomName dpy (symbols nameArray)-            str <- peekCString atom-            return str-        else -- Behaviour on error-            do-                return "Error while requesting layout!"----- 'Bad' prefixes of layouts-noLaySymbols :: [String]-noLaySymbols = ["group", "inet", "ctr", "pc", "ctrl"]----- splits the layout string into the actual layouts-splitLayout :: String -> [String]-splitLayout s = splitLayout' noLaySymbols $ split s '+'--splitLayout' :: [String] ->  [String] -> [String]---                  end of recursion, remove empty strings-splitLayout' [] s = map (takeWhile (\x -> x /= ':')) $ filter (\x -> length x > 0) s---                    remove current string if it has a 'bad' prefix-splitLayout' bad s  = splitLayout' (tail bad) [x | x <- s, not $ isPrefixOf (head bad) x]---- split String at each Char-split :: String -> Char -> [String]-split [] _ = [""]-split (c:cs) delim-    | c == delim = "" : rest-    | otherwise = (c : head rest) : tail rest-        where-            rest = split cs delim---- replaces input string if on search list (exact match) with corresponding--- element on replacement list.------ if not found, return string unchanged-searchReplaceLayout :: KbdOpts -> String -> String-searchReplaceLayout opts s = let c = findIndex (\x -> fst x == s) opts in-    case c of-        Nothing -> s-        x -> let i = (fromJust x) in-            snd $ opts!!i---- returns the active layout-getKbdLay :: Display -> KbdOpts -> IO String-getKbdLay dpy opts = do-        lay <- getLayoutStr dpy-        curLay <- getKbdLayout dpy-        return $ searchReplaceLayout opts $ (splitLayout lay)!!(curLay)----data Kbd = Kbd [(String, String)]-        deriving (Read, Show)--instance Exec Kbd where-        alias (Kbd _) = "kbd"-        start (Kbd opts) cb = do--        dpy <- openDisplay ""--        -- initial set of layout-        cb =<< getKbdLay dpy opts--        -- enable listing for-        -- group changes-        _ <- xkbSelectEventDetails dpy xkbUseCoreKbd xkbStateNotify xkbAllStateComponentsMask xkbGroupStateMask-        -- layout/geometry changes-        _ <- xkbSelectEvents dpy  xkbUseCoreKbd xkbNewKeyboardNotifyMask xkbNewKeyboardNotifyMask--        allocaXEvent $ \e -> forever $ do-            nextEvent' dpy e-            _ <- getEvent e-            cb =<< getKbdLay dpy opts--        closeDisplay dpy-        return ()---- vim:ft=haskell:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20:
− src/Plugins/Locks.hs 
@@ -1,64 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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
− src/Plugins/MBox.hs 
@@ -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 <jao@gnu.org>--- 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 "<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
− src/Plugins/Mail.hs 
@@ -1,92 +0,0 @@-{-# 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 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
− src/Plugins/MarqueePipeReader.hs 
@@ -1,70 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Plugins.MarqueePipeReader--- Copyright   :  (c) Reto Habluetzel--- License     :  BSD-style (see LICENSE)------ Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>--- Stability   :  unstable--- Portability :  unportable------ A plugin for reading from named pipes for long texts with marquee-----------------------------------------------------------------------------------module Plugins.MarqueePipeReader where--import System.IO (openFile, IOMode(ReadWriteMode), Handle)-import 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
− src/Plugins/Monitors.hs 
@@ -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 <jao@gnu.org>--- 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
− src/Plugins/Monitors/Batt.hs 
@@ -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 <jao@gnu.org>--- 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: <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'
− src/Plugins/Monitors/Bright.hs 
@@ -1,99 +0,0 @@----------------------------------------------------------------------------------- |----- 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 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 "<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-
− src/Plugins/Monitors/CatInt.hs 
@@ -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>" ["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
− src/Plugins/Monitors/Common.hs 
@@ -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 <jao@gnu.org>--- 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 "<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
− src/Plugins/Monitors/CoreCommon.hs 
@@ -1,138 +0,0 @@-{-# 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 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
− src/Plugins/Monitors/CoreTemp.hs 
@@ -1,46 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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: <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"]-       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'
− src/Plugins/Monitors/Cpu.hs 
@@ -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 <jao@gnu.org>--- 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: <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
− src/Plugins/Monitors/CpuFreq.hs 
@@ -1,44 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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: <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
− src/Plugins/Monitors/Disk.hs 
@@ -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 <jao@gnu.org>--- 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
− src/Plugins/Monitors/MPD.hs 
@@ -1,139 +0,0 @@--------------------------------------------------------------------------------- |--- 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 Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait, mpdReady ) where--import Data.List-import Data.Maybe (fromMaybe)-import Plugins.Monitors.Common-import System.Console.GetOpt-import qualified Network.MPD as M-import Control.Concurrent (threadDelay)--mpdConfig :: IO MConfig-mpdConfig = mkMConfig "MPD: <state>"-              [ "bar", "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
− src/Plugins/Monitors/Mem.hs 
@@ -1,96 +0,0 @@--------------------------------------------------------------------------------- |--- 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 Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where--import Plugins.Monitors.Common-import qualified Data.Map as M-import System.Console.GetOpt--data MemOpts = MemOpts-  { usedIconPattern :: Maybe IconPattern-  , freeIconPattern :: Maybe IconPattern-  , availableIconPattern :: Maybe IconPattern-  }--defaultOpts :: MemOpts-defaultOpts = MemOpts-  { usedIconPattern = Nothing-  , freeIconPattern = Nothing-  , availableIconPattern = Nothing-  }--options :: [OptDescr (MemOpts -> MemOpts)]-options =-  [ Option "" ["used-icon-pattern"] (ReqArg (\x o ->-     o { usedIconPattern = Just $ parseIconPattern x }) "") ""-  , Option "" ["free-icon-pattern"] (ReqArg (\x o ->-     o { freeIconPattern = Just $ parseIconPattern x }) "") ""-  , Option "" ["available-icon-pattern"] (ReqArg (\x o ->-     o { availableIconPattern = Just $ parseIconPattern x }) "") ""-  ]--parseOpts :: [String] -> IO MemOpts-parseOpts argv =-  case getOpt Permute options argv of-    (o, _, []) -> return $ foldr id defaultOpts o-    (_, _, errs) -> ioError . userError $ concat errs--memConfig :: IO MConfig-memConfig = mkMConfig-       "Mem: <usedratio>% (<cache>M)" -- template-       ["usedbar", "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
− src/Plugins/Monitors/Mpris.hs 
@@ -1,148 +0,0 @@-{-# 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 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 "<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)-                            _ -> ""
− src/Plugins/Monitors/MultiCpu.hs 
@@ -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
− src/Plugins/Monitors/Net.hs 
@@ -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
− src/Plugins/Monitors/Swap.hs 
@@ -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
− src/Plugins/Monitors/Thermal.hs 
@@ -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"
− src/Plugins/Monitors/ThermalZone.hs 
@@ -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
− src/Plugins/Monitors/Top.hs 
@@ -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
− src/Plugins/Monitors/UVMeter.hs 
@@ -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))
− src/Plugins/Monitors/Uptime.hs 
@@ -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
− src/Plugins/Monitors/Volume.hs 
@@ -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
− src/Plugins/Monitors/Weather.hs 
@@ -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
− src/Plugins/Monitors/Wireless.hs 
@@ -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]
− src/Plugins/PipeReader.hs 
@@ -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
− src/Plugins/StdinReader.hs 
@@ -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
− src/Plugins/Utils.hs 
@@ -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
− src/Plugins/XMonadLog.hs 
@@ -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
− src/Runnable.hs 
@@ -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
− src/Runnable.hs-boot 
@@ -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
− src/Signal.hs 
@@ -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 ()
− src/StatFS.hsc 
@@ -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-                       }
− src/Window.hs 
@@ -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
− src/XPMFile.hsc 
@@ -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
− src/XUtil.hsc 
@@ -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
src/Xmobar.hs view
@@ -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)
+ src/Xmobar/App/Compile.hs view
@@ -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 ()
+ src/Xmobar/App/Config.hs view
@@ -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
+ src/Xmobar/App/EventLoop.hs view
@@ -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]
+ src/Xmobar/App/Main.hs view
@@ -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
+ src/Xmobar/App/Opts.hs view
@@ -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
+ src/Xmobar/Config/Parse.hs view
@@ -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
+ src/Xmobar/Config/Types.hs view
@@ -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 )
+ src/Xmobar/Plugins/BufferedPipeReader.hs view
@@ -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
+ src/Xmobar/Plugins/CommandReader.hs view
@@ -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"
+ src/Xmobar/Plugins/Date.hs view
@@ -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
+ src/Xmobar/Plugins/DateZone.hs view
@@ -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
+ src/Xmobar/Plugins/EWMH.hs view
@@ -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
+ src/Xmobar/Plugins/Kbd.hs view
@@ -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 ()
+ src/Xmobar/Plugins/Locks.hs view
@@ -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
+ src/Xmobar/Plugins/MBox.hs view
@@ -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
+ src/Xmobar/Plugins/Mail.hs view
@@ -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
+ src/Xmobar/Plugins/MarqueePipeReader.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Alsa.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Batt.hs view
@@ -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'
+ src/Xmobar/Plugins/Monitors/Bright.hs view
@@ -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+
+ src/Xmobar/Plugins/Monitors/CatInt.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Common.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/CoreCommon.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/CoreTemp.hs view
@@ -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'
+ src/Xmobar/Plugins/Monitors/Cpu.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/CpuFreq.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Disk.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/MPD.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Mem.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Mpris.hs view
@@ -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)+                            _ -> ""
+ src/Xmobar/Plugins/Monitors/MultiCpu.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Net.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Swap.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Thermal.hs view
@@ -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"
+ src/Xmobar/Plugins/Monitors/ThermalZone.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Top.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/UVMeter.hs view
@@ -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))
+ src/Xmobar/Plugins/Monitors/Uptime.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Volume.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Weather.hs view
@@ -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
+ src/Xmobar/Plugins/Monitors/Wireless.hs view
@@ -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 []
+ src/Xmobar/Plugins/PipeReader.hs view
@@ -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
+ src/Xmobar/Plugins/StdinReader.hs view
@@ -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
+ src/Xmobar/Plugins/XMonadLog.hs view
@@ -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
+ src/Xmobar/Run/Commands.hs view
@@ -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
+ src/Xmobar/Run/Runnable.hs view
@@ -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
+ src/Xmobar/Run/Runnable.hs-boot view
@@ -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
+ src/Xmobar/Run/Template.hs view
@@ -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, "", ""]
+ src/Xmobar/Run/Types.hs view
@@ -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
+ src/Xmobar/System/DBus.hs view
@@ -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)
+ src/Xmobar/System/Environment.hs view
@@ -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
+ src/Xmobar/System/Kbd.hsc view
@@ -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!"
+ src/Xmobar/System/Localize.hsc view
@@ -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
+ src/Xmobar/System/Signal.hs view
@@ -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
+ src/Xmobar/System/StatFS.hsc view
@@ -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+                       }
+ src/Xmobar/System/Utils.hs view
@@ -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)
+ src/Xmobar/X11/Actions.hs view
@@ -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>"
+ src/Xmobar/X11/Bitmap.hs view
@@ -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
+ src/Xmobar/X11/ColorCache.hs view
@@ -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
+ src/Xmobar/X11/Draw.hs view
@@ -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
+ src/Xmobar/X11/Events.hs view
@@ -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
+ src/Xmobar/X11/MinXft.hsc view
@@ -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
+ src/Xmobar/X11/Parsers.hs view
@@ -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 '#')
+ src/Xmobar/X11/Text.hs view
@@ -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
+ src/Xmobar/X11/Types.hs view
@@ -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+          }
+ src/Xmobar/X11/Window.hs view
@@ -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
+ src/Xmobar/X11/XPMFile.hsc view
@@ -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
+ test/Xmobar/Plugins/Monitors/AlsaSpec.hs view
@@ -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
+ test/Xmobar/Plugins/Monitors/CommonSpec.hs view
@@ -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
xmobar.cabal view
@@ -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