summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Plugins
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/Plugins')
-rw-r--r--src/Xmobar/Plugins/BufferedPipeReader.hs88
-rw-r--r--src/Xmobar/Plugins/CommandReader.hs40
-rw-r--r--src/Xmobar/Plugins/Date.hs38
-rw-r--r--src/Xmobar/Plugins/DateZone.hs86
-rw-r--r--src/Xmobar/Plugins/EWMH.hs265
-rw-r--r--src/Xmobar/Plugins/Kbd.hs96
-rw-r--r--src/Xmobar/Plugins/Locks.hs64
-rw-r--r--src/Xmobar/Plugins/MBox.hs131
-rw-r--r--src/Xmobar/Plugins/Mail.hs92
-rw-r--r--src/Xmobar/Plugins/MarqueePipeReader.hs71
-rw-r--r--src/Xmobar/Plugins/Monitors.hs195
-rw-r--r--src/Xmobar/Plugins/Monitors/Alsa.hs146
-rw-r--r--src/Xmobar/Plugins/Monitors/Batt.hs247
-rw-r--r--src/Xmobar/Plugins/Monitors/Bright.hs99
-rw-r--r--src/Xmobar/Plugins/Monitors/CatInt.hs25
-rw-r--r--src/Xmobar/Plugins/Monitors/Common.hs545
-rw-r--r--src/Xmobar/Plugins/Monitors/CoreCommon.hs138
-rw-r--r--src/Xmobar/Plugins/Monitors/CoreTemp.hs45
-rw-r--r--src/Xmobar/Plugins/Monitors/Cpu.hs88
-rw-r--r--src/Xmobar/Plugins/Monitors/CpuFreq.hs44
-rw-r--r--src/Xmobar/Plugins/Monitors/Disk.hs241
-rw-r--r--src/Xmobar/Plugins/Monitors/MPD.hs139
-rw-r--r--src/Xmobar/Plugins/Monitors/Mem.hs96
-rw-r--r--src/Xmobar/Plugins/Monitors/Mpris.hs148
-rw-r--r--src/Xmobar/Plugins/Monitors/MultiCpu.hs128
-rw-r--r--src/Xmobar/Plugins/Monitors/Net.hs218
-rw-r--r--src/Xmobar/Plugins/Monitors/Swap.hs56
-rw-r--r--src/Xmobar/Plugins/Monitors/Thermal.hs39
-rw-r--r--src/Xmobar/Plugins/Monitors/ThermalZone.hs49
-rw-r--r--src/Xmobar/Plugins/Monitors/Top.hs195
-rw-r--r--src/Xmobar/Plugins/Monitors/UVMeter.hs157
-rw-r--r--src/Xmobar/Plugins/Monitors/Uptime.hs50
-rw-r--r--src/Xmobar/Plugins/Monitors/Volume.hs196
-rw-r--r--src/Xmobar/Plugins/Monitors/Weather.hs255
-rw-r--r--src/Xmobar/Plugins/Monitors/Wireless.hs70
-rw-r--r--src/Xmobar/Plugins/PipeReader.hs48
-rw-r--r--src/Xmobar/Plugins/StdinReader.hs45
-rw-r--r--src/Xmobar/Plugins/XMonadLog.hs91
38 files changed, 4764 insertions, 0 deletions
diff --git a/src/Xmobar/Plugins/BufferedPipeReader.hs b/src/Xmobar/Plugins/BufferedPipeReader.hs
new file mode 100644
index 0000000..65ecea2
--- /dev/null
+++ b/src/Xmobar/Plugins/BufferedPipeReader.hs
@@ -0,0 +1,88 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.BufferedPipeReader
+-- Copyright : (c) Jochen Keil
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin for reading (temporarily) from named pipes with reset
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.BufferedPipeReader(BufferedPipeReader(..)) where
+
+import Control.Monad(forM_, when, void)
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.IO
+import System.IO.Unsafe(unsafePerformIO)
+
+import Xmobar.Utils(hGetLineSafe)
+import Xmobar.Run.Commands
+import Xmobar.System.Signal
+import Xmobar.System.Environment
+
+data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)]
+ deriving (Read, Show)
+
+{-# NOINLINE signal #-}
+signal :: MVar SignalType
+signal = unsafePerformIO newEmptyMVar
+
+instance Exec BufferedPipeReader where
+ alias ( BufferedPipeReader a _ ) = a
+
+ trigger br@( BufferedPipeReader _ _ ) sh =
+ takeMVar signal >>= sh . Just >> trigger br sh
+
+ start ( BufferedPipeReader _ ps ) cb = do
+
+ (chan, str, rst) <- initV
+ forM_ ps $ \p -> forkIO $ reader p chan
+ writer chan str rst
+
+ where
+ initV :: IO (TChan (Int, Bool, String), TVar (Maybe String), TVar Bool)
+ initV = atomically $ do
+ tc <- newTChan
+ ts <- newTVar Nothing
+ tb <- newTVar False
+ return (tc, ts, tb)
+
+ reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO ()
+ reader p@(to, tg, fp) tc = do
+ fp' <- expandEnv fp
+ openFile fp' ReadWriteMode >>= hGetLineSafe >>= \dt ->
+ atomically $ writeTChan tc (to, tg, dt)
+ reader p tc
+
+ writer :: TChan (Int, Bool, String)
+ -> TVar (Maybe String) -> TVar Bool -> IO ()
+ writer tc ts otb = do
+ (to, tg, dt, ntb) <- update
+ cb dt
+ when tg $ putMVar signal $ Reveal 0
+ when (to /= 0) $ sfork $ reset to tg ts ntb
+ writer tc ts ntb
+
+ where
+ sfork :: IO () -> IO ()
+ sfork f = void (forkIO f)
+
+ update :: IO (Int, Bool, String, TVar Bool)
+ update = atomically $ do
+ (to, tg, dt) <- readTChan tc
+ when (to == 0) $ writeTVar ts $ Just dt
+ writeTVar otb False
+ tb <- newTVar True
+ return (to, tg, dt, tb)
+
+ reset :: Int -> Bool -> TVar (Maybe String) -> TVar Bool -> IO ()
+ reset to tg ts tb = do
+ threadDelay ( to * 100 * 1000 )
+ readTVarIO tb >>= \b -> when b $ do
+ when tg $ putMVar signal $ Hide 0
+ readTVarIO ts >>= maybe (return ()) cb
diff --git a/src/Xmobar/Plugins/CommandReader.hs b/src/Xmobar/Plugins/CommandReader.hs
new file mode 100644
index 0000000..69c8e0c
--- /dev/null
+++ b/src/Xmobar/Plugins/CommandReader.hs
@@ -0,0 +1,40 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.CommandReader
+-- Copyright : (c) John Goerzen
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin for reading from external commands
+-- note: stderr is lost here
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.CommandReader(CommandReader(..)) where
+
+import System.IO
+import Xmobar.Run.Commands
+import Xmobar.Utils (hGetLineSafe)
+import System.Process(runInteractiveCommand, getProcessExitCode)
+
+data CommandReader = CommandReader String String
+ deriving (Read, Show)
+
+instance Exec CommandReader where
+ alias (CommandReader _ a) = a
+ start (CommandReader p _) cb = do
+ (hstdin, hstdout, hstderr, ph) <- runInteractiveCommand p
+ hClose hstdin
+ hClose hstderr
+ hSetBinaryMode hstdout False
+ hSetBuffering hstdout LineBuffering
+ forever ph (hGetLineSafe hstdout >>= cb)
+ where forever ph a =
+ do a
+ ec <- getProcessExitCode ph
+ case ec of
+ Nothing -> forever ph a
+ Just _ -> cb "EXITED"
diff --git a/src/Xmobar/Plugins/Date.hs b/src/Xmobar/Plugins/Date.hs
new file mode 100644
index 0000000..62a4ee7
--- /dev/null
+++ b/src/Xmobar/Plugins/Date.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Date
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A date plugin for Xmobar
+--
+-- Usage example: in template put
+--
+-- > Run Date "%a %b %_d %Y <fc=#ee9a00> %H:%M:%S</fc>" "Mydate" 10
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Date (Date(..)) where
+
+import Xmobar.Run.Commands
+
+#if ! MIN_VERSION_time(1,5,0)
+import System.Locale
+#endif
+import Data.Time
+
+data Date = Date String String Int
+ deriving (Read, Show)
+
+instance Exec Date where
+ alias (Date _ a _) = a
+ run (Date f _ _) = date f
+ rate (Date _ _ r) = r
+
+date :: String -> IO String
+date format = fmap (formatTime defaultTimeLocale format) getZonedTime
diff --git a/src/Xmobar/Plugins/DateZone.hs b/src/Xmobar/Plugins/DateZone.hs
new file mode 100644
index 0000000..7215713
--- /dev/null
+++ b/src/Xmobar/Plugins/DateZone.hs
@@ -0,0 +1,86 @@
+{-# 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
+import Xmobar.Utils(tenthSeconds)
+
+#ifdef DATEZONE
+import Control.Concurrent.STM
+
+import System.IO.Unsafe
+
+import Data.Time.Format
+import Data.Time.LocalTime
+import Data.Time.LocalTime.TimeZone.Olson
+import Data.Time.LocalTime.TimeZone.Series
+
+import Xmobar.System.Localize
+
+#if ! MIN_VERSION_time(1,5,0)
+import System.Locale (TimeLocale)
+#endif
+#else
+import System.IO
+import Xmobar.Plugins.Date
+#endif
+
+
+
+data DateZone = DateZone String String String String Int
+ deriving (Read, Show)
+
+instance Exec DateZone where
+ alias (DateZone _ _ _ a _) = a
+#ifndef DATEZONE
+ start (DateZone f _ _ a r) cb = do
+ hPutStrLn stderr $ "Warning: DateZone plugin needs -fwith_datezone."++
+ " Using Date plugin instead."
+ start (Date f a r) cb
+#else
+ start (DateZone f l z _ r) cb = do
+ lock <- atomically $ takeTMVar localeLock
+ setupTimeLocale l
+ locale <- getTimeLocale
+ atomically $ putTMVar localeLock lock
+ if z /= "" then do
+ timeZone <- getTimeZoneSeriesFromOlsonFile ("/usr/share/zoneinfo/" ++ z)
+ go (dateZone f locale timeZone)
+ else
+ go (date f locale)
+
+ where go func = func >>= cb >> tenthSeconds r >> go func
+
+{-# NOINLINE localeLock #-}
+-- ensures that only one plugin instance sets the locale
+localeLock :: TMVar Bool
+localeLock = unsafePerformIO (newTMVarIO False)
+
+date :: String -> TimeLocale -> IO String
+date format loc = getZonedTime >>= return . formatTime loc format
+
+dateZone :: String -> TimeLocale -> TimeZoneSeries -> IO String
+dateZone format loc timeZone = getZonedTime >>= return . formatTime loc format . utcToLocalTime' timeZone . zonedTimeToUTC
+-- zonedTime <- getZonedTime
+-- return $ formatTime loc format $ utcToLocalTime' timeZone $ zonedTimeToUTC zonedTime
+#endif
diff --git a/src/Xmobar/Plugins/EWMH.hs b/src/Xmobar/Plugins/EWMH.hs
new file mode 100644
index 0000000..4a443d6
--- /dev/null
+++ b/src/Xmobar/Plugins/EWMH.hs
@@ -0,0 +1,265 @@
+{-# OPTIONS_GHC -w #-}
+{-# LANGUAGE CPP, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections, FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.EWMH
+-- Copyright : (c) Spencer Janssen
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- An experimental plugin to display EWMH pager information
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.EWMH (EWMH(..)) where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad.State
+import Control.Monad.Reader
+import Graphics.X11 hiding (Modifier, Color)
+import Graphics.X11.Xlib.Extras
+import Xmobar.Run.Commands
+#ifdef UTF8
+#undef UTF8
+import Codec.Binary.UTF8.String as UTF8
+#define UTF8
+#endif
+import Foreign.C (CChar, CLong)
+import Xmobar.Utils (nextEvent')
+
+import Data.List (intersperse, intercalate)
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+
+data EWMH = EWMH | EWMHFMT Component deriving (Read, Show)
+
+instance Exec EWMH where
+ alias EWMH = "EWMH"
+
+ start ew cb = allocaXEvent $ \ep -> execM $ do
+ d <- asks display
+ r <- asks root
+
+ liftIO xSetErrorHandler
+
+ liftIO $ selectInput d r propertyChangeMask
+ handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers
+ mapM_ ((=<< asks root) . snd) handlers'
+
+ forever $ do
+ liftIO . cb . fmtOf ew =<< get
+ liftIO $ nextEvent' d ep
+ e <- liftIO $ getEvent ep
+ case e of
+ PropertyEvent { ev_atom = a, ev_window = w } ->
+ case lookup a handlers' of
+ Just f -> f w
+ _ -> return ()
+ _ -> return ()
+
+ return ()
+
+defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty]
+ , Layout
+ , Color "#00ee00" "" :$ Short 120 :$ WindowName]
+
+fmtOf EWMH = flip fmt defaultPP
+fmtOf (EWMHFMT f) = flip fmt f
+
+sep :: [a] -> [[a]] -> [a]
+sep x xs = intercalate x $ filter (not . null) xs
+
+fmt :: EwmhState -> Component -> String
+fmt e (Text s) = s
+fmt e (l :+ r) = fmt e l ++ fmt e r
+fmt e (m :$ r) = modifier m $ fmt e r
+fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs
+fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e)
+fmt e Layout = layout e
+fmt e (Workspaces opts) = sep " "
+ [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as]
+ | (n, as) <- attrs]
+ where
+ stats i = [ (Current, i == currentDesktop e)
+ , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e)
+ -- TODO for visible , (Visibl
+ ]
+ attrs :: [(String, [WsType])]
+ attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)]
+ nonEmptys = Set.unions . map desktops . Map.elems $ clients e
+
+modifier :: Modifier -> String -> String
+modifier Hide = const ""
+modifier (Color fg bg) = \x -> concat ["<fc=", fg, if null bg then "" else "," ++ bg
+ , ">", x, "</fc>"]
+modifier (Short n) = take n
+modifier (Wrap l r) = \x -> l ++ x ++ r
+
+data Component = Text String
+ | Component :+ Component
+ | Modifier :$ Component
+ | Sep Component [Component]
+ | WindowName
+ | Layout
+ | Workspaces [WsOpt]
+ deriving (Read, Show)
+
+infixr 0 :$
+infixr 5 :+
+
+data Modifier = Hide
+ | Color String String
+ | Short Int
+ | Wrap String String
+ deriving (Read, Show)
+
+data WsOpt = Modifier :% WsType
+ | WSep Component
+ deriving (Read, Show)
+infixr 0 :%
+
+data WsType = Current | Empty | Visible
+ deriving (Read, Show, Eq)
+
+data EwmhConf = C { root :: Window
+ , display :: Display }
+
+data EwmhState = S { currentDesktop :: CLong
+ , activeWindow :: Window
+ , desktopNames :: [String]
+ , layout :: String
+ , clients :: Map Window Client }
+ deriving Show
+
+data Client = Cl { windowName :: String
+ , desktops :: Set CLong }
+ deriving Show
+
+getAtom :: String -> M Atom
+getAtom s = do
+ d <- asks display
+ liftIO $ internAtom d s False
+
+windowProperty32 :: String -> Window -> M (Maybe [CLong])
+windowProperty32 s w = do
+ C {display} <- ask
+ a <- getAtom s
+ liftIO $ getWindowProperty32 display a w
+
+windowProperty8 :: String -> Window -> M (Maybe [CChar])
+windowProperty8 s w = do
+ C {display} <- ask
+ a <- getAtom s
+ liftIO $ getWindowProperty8 display a w
+
+initialState :: EwmhState
+initialState = S 0 0 [] [] Map.empty
+
+initialClient :: Client
+initialClient = Cl "" Set.empty
+
+handlers, clientHandlers :: [(String, Updater)]
+handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop)
+ , ("_NET_DESKTOP_NAMES", updateDesktopNames )
+ , ("_NET_ACTIVE_WINDOW", updateActiveWindow)
+ , ("_NET_CLIENT_LIST", updateClientList)
+ ] ++ clientHandlers
+
+clientHandlers = [ ("_NET_WM_NAME", updateName)
+ , ("_NET_WM_DESKTOP", updateDesktop) ]
+
+newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a)
+ deriving (Monad, Functor, Applicative, MonadIO, MonadReader EwmhConf, MonadState EwmhState)
+
+execM :: M a -> IO a
+execM (M m) = do
+ d <- openDisplay ""
+ r <- rootWindow d (defaultScreen d)
+ let conf = C r d
+ evalStateT (runReaderT m (C r d)) initialState
+
+type Updater = Window -> M ()
+
+updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater
+updateCurrentDesktop _ = do
+ C {root} <- ask
+ mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root
+ case mwp of
+ Just [x] -> modify (\s -> s { currentDesktop = x })
+ _ -> return ()
+
+updateActiveWindow _ = do
+ C {root} <- ask
+ mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root
+ case mwp of
+ Just [x] -> modify (\s -> s { activeWindow = fromIntegral x })
+ _ -> return ()
+
+updateDesktopNames _ = do
+ C {root} <- ask
+ mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root
+ case mwp of
+ Just xs -> modify (\s -> s { desktopNames = parse xs })
+ _ -> return ()
+ where
+ dropNull ('\0':xs) = xs
+ dropNull xs = xs
+
+ split [] = []
+ split xs = case span (/= '\0') xs of
+ (x, ys) -> x : split (dropNull ys)
+ parse = split . decodeCChar
+
+updateClientList _ = do
+ C {root} <- ask
+ mwp <- windowProperty32 "_NET_CLIENT_LIST" root
+ case mwp of
+ Just xs -> do
+ cl <- gets clients
+ let cl' = Map.fromList $ map ((, initialClient) . fromIntegral) xs
+ dels = Map.difference cl cl'
+ new = Map.difference cl' cl
+ modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'})
+ mapM_ (unmanage . fst) (Map.toList dels)
+ mapM_ (listen . fst) (Map.toList cl')
+ mapM_ (update . fst) (Map.toList new)
+ _ -> return ()
+ where
+ unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0
+ listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask
+ update w = mapM_ (($ w) . snd) clientHandlers
+
+modifyClient :: Window -> (Client -> Client) -> M ()
+modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s })
+ where
+ f' Nothing = Just $ f initialClient
+ f' (Just x) = Just $ f x
+
+updateName w = do
+ mwp <- windowProperty8 "_NET_WM_NAME" w
+ case mwp of
+ Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs })
+ _ -> return ()
+
+updateDesktop w = do
+ mwp <- windowProperty32 "_NET_WM_DESKTOP" w
+ case mwp of
+ Just x -> modifyClient w (\c -> c { desktops = Set.fromList x })
+ _ -> return ()
+
+decodeCChar :: [CChar] -> String
+#ifdef UTF8
+#undef UTF8
+decodeCChar = UTF8.decode . map fromIntegral
+#define UTF8
+#else
+decodeCChar = map (toEnum . fromIntegral)
+#endif
diff --git a/src/Xmobar/Plugins/Kbd.hs b/src/Xmobar/Plugins/Kbd.hs
new file mode 100644
index 0000000..f4dad36
--- /dev/null
+++ b/src/Xmobar/Plugins/Kbd.hs
@@ -0,0 +1,96 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Kbd
+-- Copyright : (c) Martin Perner
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Martin Perner <martin@perner.cc>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A keyboard layout indicator for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Kbd(Kbd(..)) where
+
+import Data.List (isPrefixOf, findIndex)
+import Data.Maybe (fromJust)
+import Control.Monad (forever)
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+import Xmobar.Run.Commands
+import Xmobar.Utils (nextEvent')
+import Xmobar.System.Kbd
+
+
+-- 'Bad' prefixes of layouts
+noLaySymbols :: [String]
+noLaySymbols = ["group", "inet", "ctr", "pc", "ctrl"]
+
+
+-- splits the layout string into the actual layouts
+splitLayout :: String -> [String]
+splitLayout s = splitLayout' noLaySymbols $ split s '+'
+
+splitLayout' :: [String] -> [String] -> [String]
+-- end of recursion, remove empty strings
+splitLayout' [] s = map (takeWhile (/= ':')) $ filter (not . null) s
+-- remove current string if it has a 'bad' prefix
+splitLayout' bad s =
+ splitLayout' (tail bad) [x | x <- s, not $ isPrefixOf (head bad) x]
+
+-- split String at each Char
+split :: String -> Char -> [String]
+split [] _ = [""]
+split (c:cs) delim
+ | c == delim = "" : rest
+ | otherwise = (c : head rest) : tail rest
+ where
+ rest = split cs delim
+
+-- replaces input string if on search list (exact match) with corresponding
+-- element on replacement list.
+--
+-- if not found, return string unchanged
+searchReplaceLayout :: KbdOpts -> String -> String
+searchReplaceLayout opts s = let c = findIndex (\x -> fst x == s) opts in
+ case c of
+ Nothing -> s
+ x -> let i = fromJust x in snd $ opts!!i
+
+-- returns the active layout
+getKbdLay :: Display -> KbdOpts -> IO String
+getKbdLay dpy opts = do
+ lay <- getLayoutStr dpy
+ curLay <- getKbdLayout dpy
+ return $ searchReplaceLayout opts $ splitLayout lay!!curLay
+
+
+
+newtype Kbd = Kbd [(String, String)]
+ deriving (Read, Show)
+
+instance Exec Kbd where
+ alias (Kbd _) = "kbd"
+ start (Kbd opts) cb = do
+
+ dpy <- openDisplay ""
+
+ -- initial set of layout
+ cb =<< getKbdLay dpy opts
+
+ -- enable listing for
+ -- group changes
+ _ <- xkbSelectEventDetails dpy xkbUseCoreKbd xkbStateNotify xkbAllStateComponentsMask xkbGroupStateMask
+ -- layout/geometry changes
+ _ <- xkbSelectEvents dpy xkbUseCoreKbd xkbNewKeyboardNotifyMask xkbNewKeyboardNotifyMask
+
+ allocaXEvent $ \e -> forever $ do
+ nextEvent' dpy e
+ _ <- getEvent e
+ cb =<< getKbdLay dpy opts
+
+ closeDisplay dpy
+ return ()
diff --git a/src/Xmobar/Plugins/Locks.hs b/src/Xmobar/Plugins/Locks.hs
new file mode 100644
index 0000000..19bce20
--- /dev/null
+++ b/src/Xmobar/Plugins/Locks.hs
@@ -0,0 +1,64 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Locks
+-- Copyright : (c) Patrick Chilton
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Patrick Chilton <chpatrick@gmail.com>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin that displays the status of the lock keys.
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Locks(Locks(..)) where
+
+import Graphics.X11
+import Data.List
+import Data.Bits
+import Control.Monad
+import Graphics.X11.Xlib.Extras
+import Xmobar.Run.Commands
+import Xmobar.System.Kbd
+import Xmobar.Utils (nextEvent')
+
+data Locks = Locks
+ deriving (Read, Show)
+
+locks :: [ ( KeySym, String )]
+locks = [ ( xK_Caps_Lock, "CAPS" )
+ , ( xK_Num_Lock, "NUM" )
+ , ( xK_Scroll_Lock, "SCROLL" )
+ ]
+
+run' :: Display -> Window -> IO String
+run' d root = do
+ modMap <- getModifierMapping d
+ ( _, _, _, _, _, _, _, m ) <- queryPointer d root
+
+ ls <- filterM ( \( ks, _ ) -> do
+ kc <- keysymToKeycode d ks
+ return $ case find (elem kc . snd) modMap of
+ Nothing -> False
+ Just ( i, _ ) -> testBit m (fromIntegral i)
+ ) locks
+
+ return $ unwords $ map snd ls
+
+instance Exec Locks where
+ alias Locks = "locks"
+ start Locks cb = do
+ d <- openDisplay ""
+ root <- rootWindow d (defaultScreen d)
+ _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m
+
+ allocaXEvent $ \ep -> forever $ do
+ cb =<< run' d root
+ nextEvent' d ep
+ getEvent ep
+
+ closeDisplay d
+ return ()
+ where
+ m = xkbAllStateComponentsMask
diff --git a/src/Xmobar/Plugins/MBox.hs b/src/Xmobar/Plugins/MBox.hs
new file mode 100644
index 0000000..4bd0ebd
--- /dev/null
+++ b/src/Xmobar/Plugins/MBox.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.MBox
+-- Copyright : (c) Jose A Ortega Ruiz
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin for checking mail in mbox files.
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.MBox (MBox(..)) where
+
+import Prelude
+import Xmobar.Run.Commands
+#ifdef INOTIFY
+import Xmobar.Utils (changeLoop, expandHome)
+
+import Control.Monad (when)
+import Control.Concurrent.STM
+import Control.Exception (SomeException (..), handle, evaluate)
+
+import System.Console.GetOpt
+import System.Directory (doesFileExist)
+import System.FilePath ((</>))
+import System.INotify (Event(..), EventVariety(..), initINotify, addWatch)
+
+import qualified Data.ByteString.Lazy.Char8 as B
+
+#if MIN_VERSION_hinotify(0,3,10)
+import qualified Data.ByteString.Char8 as BS (ByteString, pack)
+pack :: String -> BS.ByteString
+pack = BS.pack
+#else
+pack :: String -> String
+pack = id
+#endif
+
+data Options = Options
+ { oAll :: Bool
+ , oUniq :: Bool
+ , oDir :: FilePath
+ , oPrefix :: String
+ , oSuffix :: String
+ }
+
+defaults :: Options
+defaults = Options {
+ oAll = False, oUniq = False, oDir = "", oPrefix = "", oSuffix = ""
+ }
+
+options :: [OptDescr (Options -> Options)]
+options =
+ [ Option "a" ["all"] (NoArg (\o -> o { oAll = True })) ""
+ , Option "u" [] (NoArg (\o -> o { oUniq = True })) ""
+ , Option "d" ["dir"] (ReqArg (\x o -> o { oDir = x }) "") ""
+ , Option "p" ["prefix"] (ReqArg (\x o -> o { oPrefix = x }) "") ""
+ , Option "s" ["suffix"] (ReqArg (\x o -> o { oSuffix = x }) "") ""
+ ]
+
+parseOptions :: [String] -> IO Options
+parseOptions args =
+ case getOpt Permute options args of
+ (o, _, []) -> return $ foldr id defaults o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+#else
+import System.IO
+#endif
+
+-- | A list of display names, paths to mbox files and display colours,
+-- followed by a list of options.
+data MBox = MBox [(String, FilePath, String)] [String] String
+ deriving (Read, Show)
+
+instance Exec MBox where
+ alias (MBox _ _ a) = a
+#ifndef INOTIFY
+ start _ _ =
+ hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify" ++
+ " but the MBox plugin requires it"
+#else
+ start (MBox boxes args _) cb = do
+ opts <- parseOptions args
+ let showAll = oAll opts
+ prefix = oPrefix opts
+ suffix = oSuffix opts
+ uniq = oUniq opts
+ names = map (\(t, _, _) -> t) boxes
+ colors = map (\(_, _, c) -> c) boxes
+ extractPath (_, f, _) = expandHome $ oDir opts </> f
+ events = [CloseWrite]
+
+ i <- initINotify
+ vs <- mapM (\b -> do
+ f <- extractPath b
+ exists <- doesFileExist f
+ n <- if exists then countMails f else return (-1)
+ v <- newTVarIO (f, n)
+ when exists $
+ addWatch i events (pack f) (handleNotification v) >> return ()
+ return v)
+ boxes
+
+ changeLoop (mapM (fmap snd . readTVar) vs) $ \ns ->
+ let s = unwords [ showC uniq m n c | (m, n, c) <- zip3 names ns colors
+ , showAll || n > 0 ]
+ in cb (if null s then "" else prefix ++ s ++ suffix)
+
+showC :: Bool -> String -> Int -> String -> String
+showC u m n c =
+ if c == "" then msg else "<fc=" ++ c ++ ">" ++ msg ++ "</fc>"
+ where msg = m ++ if not u || n > 1 then show n else ""
+
+countMails :: FilePath -> IO Int
+countMails f =
+ handle (\(SomeException _) -> evaluate 0)
+ (do txt <- B.readFile f
+ evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt)
+ where from = B.pack "From "
+
+handleNotification :: TVar (FilePath, Int) -> Event -> IO ()
+handleNotification v _ = do
+ (p, _) <- atomically $ readTVar v
+ n <- countMails p
+ atomically $ writeTVar v (p, n)
+#endif
diff --git a/src/Xmobar/Plugins/Mail.hs b/src/Xmobar/Plugins/Mail.hs
new file mode 100644
index 0000000..d59e70d
--- /dev/null
+++ b/src/Xmobar/Plugins/Mail.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Mail
+-- Copyright : (c) Spencer Janssen
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Spencer Janssen <sjanssen@cse.unl.edu>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin for checking mail.
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Mail(Mail(..)) where
+
+import Xmobar.Run.Commands
+#ifdef INOTIFY
+import Xmobar.Utils (expandHome, changeLoop)
+
+import Control.Monad
+import Control.Concurrent.STM
+
+import System.Directory
+import System.FilePath
+import System.INotify
+
+import Data.List (isPrefixOf)
+import Data.Set (Set)
+import qualified Data.Set as S
+
+#if MIN_VERSION_hinotify(0,3,10)
+import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack)
+unpack :: BS.ByteString -> String
+unpack = BS.unpack
+pack :: String -> BS.ByteString
+pack = BS.pack
+#else
+unpack :: String -> String
+unpack = id
+pack :: String -> String
+pack = id
+#endif
+#else
+import System.IO
+#endif
+
+
+-- | A list of mail box names and paths to maildirs.
+data Mail = Mail [(String, FilePath)] String
+ deriving (Read, Show)
+
+instance Exec Mail where
+ alias (Mail _ a) = a
+#ifndef INOTIFY
+ start _ _ =
+ hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify,"
+ ++ " but the Mail plugin requires it."
+#else
+ start (Mail ms _) cb = do
+ vs <- mapM (const $ newTVarIO S.empty) ms
+
+ let ts = map fst ms
+ rs = map ((</> "new") . snd) ms
+ ev = [Move, MoveIn, MoveOut, Create, Delete]
+
+ ds <- mapM expandHome rs
+ i <- initINotify
+ zipWithM_ (\d v -> addWatch i ev d (handle v)) (map pack ds) vs
+
+ forM_ (zip ds vs) $ \(d, v) -> do
+ s <- fmap (S.fromList . filter (not . isPrefixOf "."))
+ $ getDirectoryContents d
+ atomically $ modifyTVar v (S.union s)
+
+ changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns ->
+ cb . unwords $ [m ++ show n
+ | (m, n) <- zip ts ns
+ , n /= 0 ]
+
+handle :: TVar (Set String) -> Event -> IO ()
+handle v e = atomically $ modifyTVar v $ case e of
+ Created {} -> create
+ MovedIn {} -> create
+ Deleted {} -> delete
+ MovedOut {} -> delete
+ _ -> id
+ where
+ delete = S.delete ((unpack . filePath) e)
+ create = S.insert ((unpack . filePath) e)
+#endif
diff --git a/src/Xmobar/Plugins/MarqueePipeReader.hs b/src/Xmobar/Plugins/MarqueePipeReader.hs
new file mode 100644
index 0000000..a48e81c
--- /dev/null
+++ b/src/Xmobar/Plugins/MarqueePipeReader.hs
@@ -0,0 +1,71 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.MarqueePipeReader
+-- Copyright : (c) Reto Habluetzel
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin for reading from named pipes for long texts with marquee
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.MarqueePipeReader where
+
+import System.IO (openFile, IOMode(ReadWriteMode), Handle)
+import Xmobar.System.Environment
+import Xmobar.Utils(tenthSeconds, hGetLineSafe)
+import Xmobar.Run.Commands(Exec(alias, start))
+import System.Posix.Files (getFileStatus, isNamedPipe)
+import Control.Concurrent(forkIO, threadDelay)
+import Control.Concurrent.STM (TChan, atomically, writeTChan, tryReadTChan, newTChan)
+import Control.Exception
+import Control.Monad(forever, unless)
+import Control.Applicative ((<$>))
+
+type Length = Int -- length of the text to display
+type Rate = Int -- delay in tenth seconds
+type Separator = String -- if text wraps around, use separator
+
+data MarqueePipeReader = MarqueePipeReader String (Length, Rate, Separator) String
+ deriving (Read, Show)
+
+instance Exec MarqueePipeReader where
+ alias (MarqueePipeReader _ _ a) = a
+ start (MarqueePipeReader p (len, rate, sep) _) cb = do
+ (def, pipe) <- split ':' <$> expandEnv p
+ unless (null def) (cb def)
+ checkPipe pipe
+ h <- openFile pipe ReadWriteMode
+ line <- hGetLineSafe h
+ chan <- atomically newTChan
+ forkIO $ writer (toInfTxt line sep) sep len rate chan cb
+ forever $ pipeToChan h chan
+ where
+ split c xs | c `elem` xs = let (pre, post) = span (c /=) xs
+ in (pre, dropWhile (c ==) post)
+ | otherwise = ([], xs)
+
+pipeToChan :: Handle -> TChan String -> IO ()
+pipeToChan h chan = do
+ line <- hGetLineSafe h
+ atomically $ writeTChan chan line
+
+writer :: String -> Separator -> Length -> Rate -> TChan String -> (String -> IO ()) -> IO ()
+writer txt sep len rate chan cb = do
+ cb (take len txt)
+ mbnext <- atomically $ tryReadTChan chan
+ case mbnext of
+ Just new -> writer (toInfTxt new sep) sep len rate chan cb
+ Nothing -> tenthSeconds rate >> writer (drop 1 txt) sep len rate chan cb
+
+toInfTxt :: String -> String -> String
+toInfTxt line sep = concat (repeat $ line ++ " " ++ sep ++ " ")
+
+checkPipe :: FilePath -> IO ()
+checkPipe file = handle (\(SomeException _) -> waitForPipe) $ do
+ status <- getFileStatus file
+ unless (isNamedPipe status) waitForPipe
+ where waitForPipe = threadDelay 1000 >> checkPipe file
diff --git a/src/Xmobar/Plugins/Monitors.hs b/src/Xmobar/Plugins/Monitors.hs
new file mode 100644
index 0000000..fe909d8
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors.hs
@@ -0,0 +1,195 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Xmobar.Plugins.Monitors
+-- Copyright : (c) 2010, 2011, 2012, 2013, 2017, 2018 Jose Antonio Ortega Ruiz
+-- (c) 2007-10 Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- The system monitor plugin for Xmobar.
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors where
+
+import Xmobar.Run.Commands
+
+import Xmobar.Plugins.Monitors.Common (runM, runMD)
+#ifdef WEATHER
+import Xmobar.Plugins.Monitors.Weather
+#endif
+import Xmobar.Plugins.Monitors.Net
+import Xmobar.Plugins.Monitors.Mem
+import Xmobar.Plugins.Monitors.Swap
+import Xmobar.Plugins.Monitors.Cpu
+import Xmobar.Plugins.Monitors.MultiCpu
+import Xmobar.Plugins.Monitors.Batt
+import Xmobar.Plugins.Monitors.Bright
+import Xmobar.Plugins.Monitors.Thermal
+import Xmobar.Plugins.Monitors.ThermalZone
+import Xmobar.Plugins.Monitors.CpuFreq
+import Xmobar.Plugins.Monitors.CoreTemp
+import Xmobar.Plugins.Monitors.Disk
+import Xmobar.Plugins.Monitors.Top
+import Xmobar.Plugins.Monitors.Uptime
+import Xmobar.Plugins.Monitors.CatInt
+#ifdef UVMETER
+import Xmobar.Plugins.Monitors.UVMeter
+#endif
+#ifdef IWLIB
+import Xmobar.Plugins.Monitors.Wireless
+#endif
+#ifdef LIBMPD
+import Xmobar.Plugins.Monitors.MPD
+import Xmobar.Plugins.Monitors.Common (runMBD)
+#endif
+#ifdef ALSA
+import Xmobar.Plugins.Monitors.Volume
+import Xmobar.Plugins.Monitors.Alsa
+#endif
+#ifdef MPRIS
+import Xmobar.Plugins.Monitors.Mpris
+#endif
+
+data Monitors = Network Interface Args Rate
+ | DynNetwork Args Rate
+ | BatteryP Args Args Rate
+ | BatteryN Args Args Rate Alias
+ | Battery Args Rate
+ | DiskU DiskSpec Args Rate
+ | DiskIO DiskSpec Args Rate
+ | Thermal Zone Args Rate
+ | ThermalZone ZoneNo Args Rate
+ | Memory Args Rate
+ | Swap Args Rate
+ | Cpu Args Rate
+ | MultiCpu Args Rate
+ | Brightness Args Rate
+ | CpuFreq Args Rate
+ | CoreTemp Args Rate
+ | TopProc Args Rate
+ | TopMem Args Rate
+ | Uptime Args Rate
+ | CatInt Int FilePath Args Rate
+#ifdef WEATHER
+ | Weather Station Args Rate
+#endif
+#ifdef UVMETER
+ | UVMeter Station Args Rate
+#endif
+#ifdef IWLIB
+ | Wireless Interface Args Rate
+#endif
+#ifdef LIBMPD
+ | MPD Args Rate
+ | AutoMPD Args
+#endif
+#ifdef ALSA
+ | Volume String String Args Rate
+ | Alsa String String Args
+#endif
+#ifdef MPRIS
+ | Mpris1 String Args Rate
+ | Mpris2 String Args Rate
+#endif
+ deriving (Show,Read,Eq)
+
+type Args = [String]
+type Program = String
+type Alias = String
+type Station = String
+type Zone = String
+type ZoneNo = Int
+type Interface = String
+type Rate = Int
+type DiskSpec = [(String, String)]
+
+instance Exec Monitors where
+#ifdef WEATHER
+ alias (Weather s _ _) = s
+#endif
+ alias (Network i _ _) = i
+ alias (DynNetwork _ _) = "dynnetwork"
+ alias (Thermal z _ _) = z
+ alias (ThermalZone z _ _) = "thermal" ++ show z
+ alias (Memory _ _) = "memory"
+ alias (Swap _ _) = "swap"
+ alias (Cpu _ _) = "cpu"
+ alias (MultiCpu _ _) = "multicpu"
+ alias (Battery _ _) = "battery"
+ alias BatteryP {} = "battery"
+ alias (BatteryN _ _ _ a)= a
+ alias (Brightness _ _) = "bright"
+ alias (CpuFreq _ _) = "cpufreq"
+ alias (TopProc _ _) = "top"
+ alias (TopMem _ _) = "topmem"
+ alias (CoreTemp _ _) = "coretemp"
+ alias DiskU {} = "disku"
+ alias DiskIO {} = "diskio"
+ alias (Uptime _ _) = "uptime"
+ alias (CatInt n _ _ _) = "cat" ++ show n
+#ifdef UVMETER
+ alias (UVMeter s _ _) = "uv " ++ s
+#endif
+#ifdef IWLIB
+ alias (Wireless i _ _) = i ++ "wi"
+#endif
+#ifdef LIBMPD
+ alias (MPD _ _) = "mpd"
+ alias (AutoMPD _) = "autompd"
+#endif
+#ifdef ALSA
+ alias (Volume m c _ _) = m ++ ":" ++ c
+ alias (Alsa m c _) = "alsa:" ++ m ++ ":" ++ c
+#endif
+#ifdef MPRIS
+ alias (Mpris1 _ _ _) = "mpris1"
+ alias (Mpris2 _ _ _) = "mpris2"
+#endif
+ start (Network i a r) = startNet i a r
+ start (DynNetwork a r) = startDynNet a r
+ start (Cpu a r) = startCpu a r
+ start (MultiCpu a r) = startMultiCpu a r
+ start (TopProc a r) = startTop a r
+ start (TopMem a r) = runM a topMemConfig runTopMem r
+#ifdef WEATHER
+ start (Weather s a r) = runMD (a ++ [s]) weatherConfig runWeather r weatherReady
+#endif
+ start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r
+ start (ThermalZone z a r) =
+ runM (a ++ [show z]) thermalZoneConfig runThermalZone r
+ start (Memory a r) = runM a memConfig runMem r
+ start (Swap a r) = runM a swapConfig runSwap r
+ start (Battery a r) = runM a battConfig runBatt r
+ start (BatteryP s a r) = runM a battConfig (runBatt' s) r
+ start (BatteryN s a r _) = runM a battConfig (runBatt' s) r
+ start (Brightness a r) = runM a brightConfig runBright r
+ start (CpuFreq a r) = runM a cpuFreqConfig runCpuFreq r
+ start (CoreTemp a r) = runM a coreTempConfig runCoreTemp r
+ start (DiskU s a r) = runM a diskUConfig (runDiskU s) r
+ start (DiskIO s a r) = startDiskIO s a r
+ start (Uptime a r) = runM a uptimeConfig runUptime r
+ start (CatInt _ s a r) = runM a catIntConfig (runCatInt s) r
+#ifdef UVMETER
+ start (UVMeter s a r) = runM (a ++ [s]) uvConfig runUVMeter r
+#endif
+#ifdef IWLIB
+ start (Wireless i a r) = runM a wirelessConfig (runWireless i) r
+#endif
+#ifdef LIBMPD
+ start (MPD a r) = runMD a mpdConfig runMPD r mpdReady
+ start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady
+#endif
+#ifdef ALSA
+ start (Volume m c a r) = runM a volumeConfig (runVolume m c) r
+ start (Alsa m c a) = startAlsaPlugin m c a
+#endif
+#ifdef MPRIS
+ start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r
+ start (Mpris2 s a r) = runM a mprisConfig (runMPRIS2 s) r
+#endif
diff --git a/src/Xmobar/Plugins/Monitors/Alsa.hs b/src/Xmobar/Plugins/Monitors/Alsa.hs
new file mode 100644
index 0000000..21a2786
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Alsa.hs
@@ -0,0 +1,146 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Alsa
+-- Copyright : (c) 2018 Daniel Schüssler
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Event-based variant of the Volume plugin.
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Alsa
+ ( startAlsaPlugin
+ , withMonitorWaiter
+ , parseOptsIncludingMonitorArgs
+ , AlsaOpts(aoAlsaCtlPath)
+ ) where
+
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Exception
+import Control.Monad
+import Xmobar.Plugins.Monitors.Common
+import qualified Xmobar.Plugins.Monitors.Volume as Volume;
+import System.Console.GetOpt
+import System.Directory
+import System.Exit
+import System.IO
+import System.Process
+
+data AlsaOpts = AlsaOpts
+ { aoVolumeOpts :: Volume.VolumeOpts
+ , aoAlsaCtlPath :: Maybe FilePath
+ }
+
+defaultOpts :: AlsaOpts
+defaultOpts = AlsaOpts Volume.defaultOpts Nothing
+
+alsaCtlOptionName :: String
+alsaCtlOptionName = "alsactl"
+
+options :: [OptDescr (AlsaOpts -> AlsaOpts)]
+options =
+ Option "" [alsaCtlOptionName] (ReqArg (\x o ->
+ o { aoAlsaCtlPath = Just x }) "") ""
+ : fmap (fmap modifyVolumeOpts) Volume.options
+ where
+ modifyVolumeOpts f o = o { aoVolumeOpts = f (aoVolumeOpts o) }
+
+parseOpts :: [String] -> IO AlsaOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+parseOptsIncludingMonitorArgs :: [String] -> IO AlsaOpts
+parseOptsIncludingMonitorArgs args =
+ -- Drop generic Monitor args first
+ case getOpt Permute [] args of
+ (_, args', _) -> parseOpts args'
+
+startAlsaPlugin :: String -> String -> [String] -> (String -> IO ()) -> IO ()
+startAlsaPlugin mixerName controlName args cb = do
+ opts <- parseOptsIncludingMonitorArgs args
+
+ let run args2 = do
+ -- Replicating the reparsing logic used by other plugins for now,
+ -- but it seems the option parsing could be floated out (actually,
+ -- GHC could in principle do it already since getOpt is pure, but
+ -- it would have to inline 'runMBD', 'doArgs' and 'parseOpts' to see
+ -- it, which probably isn't going to happen with the default
+ -- optimization settings).
+ opts2 <- io $ parseOpts args2
+ Volume.runVolumeWith (aoVolumeOpts opts2) mixerName controlName
+
+ withMonitorWaiter mixerName (aoAlsaCtlPath opts) $ \wait_ ->
+ runMB args Volume.volumeConfig run wait_ cb
+
+withMonitorWaiter :: String -> Maybe FilePath -> (IO () -> IO a) -> IO a
+withMonitorWaiter mixerName alsaCtlPath cont = do
+ mvar <- newMVar ()
+
+ path <- determineAlsaCtlPath
+
+ bracket (async $ readerThread mvar path) cancel $ \a -> do
+
+ -- Throw on this thread if there's an exception
+ -- on the reader thread.
+ link a
+
+ cont $ takeMVar mvar
+
+ where
+
+ readerThread mvar path =
+ let createProc = (proc "stdbuf" ["-oL", path, "monitor", mixerName])
+ {std_out = CreatePipe}
+ in
+ withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do
+ hSetBuffering alsaOut LineBuffering
+
+ forever $ do
+ c <- hGetChar alsaOut
+ when (c == '\n') $
+ -- This uses 'tryPutMVar' because 'putMVar' would make 'runVolume' run
+ -- once for each event. But we want it to run only once after a burst
+ -- of events.
+ void $ tryPutMVar mvar ()
+
+ defaultPath = "/usr/sbin/alsactl"
+
+ determineAlsaCtlPath =
+ case alsaCtlPath of
+ Just path -> do
+ found <- doesFileExist path
+ if found
+ then pure path
+ else throwIO . ErrorCall $
+ "Specified alsactl file " ++ path ++ " does not exist"
+
+ Nothing -> do
+ (ec, path, err) <- readProcessWithExitCode "which" ["alsactl"] ""
+ unless (null err) $ hPutStrLn stderr err
+ case ec of
+ ExitSuccess -> pure $ trimTrailingNewline path
+ ExitFailure _ -> do
+ found <- doesFileExist defaultPath
+ if found
+ then pure defaultPath
+ else throwIO . ErrorCall $
+ "alsactl not found in PATH or at " ++
+ show defaultPath ++
+ "; please specify with --" ++
+ alsaCtlOptionName ++ "=/path/to/alsactl"
+
+
+-- This is necessarily very inefficient on 'String's
+trimTrailingNewline :: String -> String
+trimTrailingNewline x =
+ case reverse x of
+ '\n' : '\r' : y -> reverse y
+ '\n' : y -> reverse y
+ _ -> x
diff --git a/src/Xmobar/Plugins/Monitors/Batt.hs b/src/Xmobar/Plugins/Monitors/Batt.hs
new file mode 100644
index 0000000..80f4275
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Batt.hs
@@ -0,0 +1,247 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Batt
+-- Copyright : (c) 2010, 2011, 2012, 2013, 2015, 2016, 2018 Jose A Ortega
+-- (c) 2010 Andrea Rossato, Petr Rockai
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A battery monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where
+
+import Control.Exception (SomeException, handle)
+import Xmobar.Plugins.Monitors.Common
+import System.FilePath ((</>))
+import System.IO (IOMode(ReadMode), hGetLine, withFile)
+import System.Posix.Files (fileExist)
+import System.Console.GetOpt
+import Data.List (sort, sortBy, group)
+import Data.Maybe (fromMaybe)
+import Data.Ord (comparing)
+import Text.Read (readMaybe)
+
+data BattOpts = BattOpts
+ { onString :: String
+ , offString :: String
+ , idleString :: String
+ , posColor :: Maybe String
+ , lowWColor :: Maybe String
+ , mediumWColor :: Maybe String
+ , highWColor :: Maybe String
+ , lowThreshold :: Float
+ , highThreshold :: Float
+ , onlineFile :: FilePath
+ , scale :: Float
+ , onIconPattern :: Maybe IconPattern
+ , offIconPattern :: Maybe IconPattern
+ , idleIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: BattOpts
+defaultOpts = BattOpts
+ { onString = "On"
+ , offString = "Off"
+ , idleString = "On"
+ , posColor = Nothing
+ , lowWColor = Nothing
+ , mediumWColor = Nothing
+ , highWColor = Nothing
+ , lowThreshold = 10
+ , highThreshold = 12
+ , onlineFile = "AC/online"
+ , scale = 1e6
+ , onIconPattern = Nothing
+ , offIconPattern = Nothing
+ , idleIconPattern = Nothing
+ }
+
+options :: [OptDescr (BattOpts -> BattOpts)]
+options =
+ [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") ""
+ , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") ""
+ , Option "i" ["idle"] (ReqArg (\x o -> o { idleString = x }) "") ""
+ , Option "p" ["positive"] (ReqArg (\x o -> o { posColor = Just x }) "") ""
+ , Option "l" ["low"] (ReqArg (\x o -> o { lowWColor = Just x }) "") ""
+ , Option "m" ["medium"] (ReqArg (\x o -> o { mediumWColor = Just x }) "") ""
+ , Option "h" ["high"] (ReqArg (\x o -> o { highWColor = Just x }) "") ""
+ , Option "L" ["lowt"] (ReqArg (\x o -> o { lowThreshold = read x }) "") ""
+ , Option "H" ["hight"] (ReqArg (\x o -> o { highThreshold = read x }) "") ""
+ , Option "f" ["online"] (ReqArg (\x o -> o { onlineFile = x }) "") ""
+ , Option "s" ["scale"] (ReqArg (\x o -> o {scale = read x}) "") ""
+ , Option "" ["on-icon-pattern"] (ReqArg (\x o ->
+ o { onIconPattern = Just $ parseIconPattern x }) "") ""
+ , Option "" ["off-icon-pattern"] (ReqArg (\x o ->
+ o { offIconPattern = Just $ parseIconPattern x }) "") ""
+ , Option "" ["idle-icon-pattern"] (ReqArg (\x o ->
+ o { idleIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+parseOpts :: [String] -> IO BattOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+data Status = Charging | Discharging | Full | Idle | Unknown deriving (Read, Eq)
+
+data Result = Result Float Float Float Status | NA
+
+sysDir :: FilePath
+sysDir = "/sys/class/power_supply"
+
+battConfig :: IO MConfig
+battConfig = mkMConfig
+ "Batt: <watts>, <left>% / <timeleft>" -- template
+ ["leftbar", "leftvbar", "left", "acstatus", "timeleft", "watts", "leftipat"] -- replacements
+
+data Files = Files
+ { fFull :: String
+ , fNow :: String
+ , fVoltage :: String
+ , fCurrent :: String
+ , fStatus :: String
+ , isCurrent :: Bool
+ } | NoFiles deriving Eq
+
+data Battery = Battery
+ { full :: !Float
+ , now :: !Float
+ , power :: !Float
+ , status :: !String
+ }
+
+safeFileExist :: String -> String -> IO Bool
+safeFileExist d f = handle noErrors $ fileExist (d </> f)
+ where noErrors = const (return False) :: SomeException -> IO Bool
+
+batteryFiles :: String -> IO Files
+batteryFiles bat =
+ do is_charge <- exists "charge_now"
+ is_energy <- if is_charge then return False else exists "energy_now"
+ is_power <- exists "power_now"
+ plain <- exists (if is_charge then "charge_full" else "energy_full")
+ let cf = if is_power then "power_now" else "current_now"
+ sf = if plain then "" else "_design"
+ return $ case (is_charge, is_energy) of
+ (True, _) -> files "charge" cf sf is_power
+ (_, True) -> files "energy" cf sf is_power
+ _ -> NoFiles
+ where prefix = sysDir </> bat
+ exists = safeFileExist prefix
+ files ch cf sf ip = Files { fFull = prefix </> ch ++ "_full" ++ sf
+ , fNow = prefix </> ch ++ "_now"
+ , fCurrent = prefix </> cf
+ , fVoltage = prefix </> "voltage_now"
+ , fStatus = prefix </> "status"
+ , isCurrent = not ip}
+
+haveAc :: FilePath -> IO Bool
+haveAc f =
+ handle onError $ withFile (sysDir </> f) ReadMode (fmap (== "1") . hGetLine)
+ where onError = const (return False) :: SomeException -> IO Bool
+
+readBattery :: Float -> Files -> IO Battery
+readBattery _ NoFiles = return $ Battery 0 0 0 "Unknown"
+readBattery sc files =
+ do a <- grab $ fFull files
+ b <- grab $ fNow files
+ d <- grab $ fCurrent files
+ s <- grabs $ fStatus files
+ let sc' = if isCurrent files then sc / 10 else sc
+ a' = max a b -- sometimes the reported max charge is lower than
+ return $ Battery (3600 * a' / sc') -- wattseconds
+ (3600 * b / sc') -- wattseconds
+ (d / sc') -- watts
+ s -- string: Discharging/Charging/Full
+ where grab f = handle onError $ withFile f ReadMode (fmap read . hGetLine)
+ onError = const (return (-1)) :: SomeException -> IO Float
+ grabs f = handle onError' $ withFile f ReadMode hGetLine
+ onError' = const (return "Unknown") :: SomeException -> IO String
+
+-- sortOn is only available starting at ghc 7.10
+sortOn :: Ord b => (a -> b) -> [a] -> [a]
+sortOn f =
+ map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
+
+mostCommonDef :: Eq a => a -> [a] -> a
+mostCommonDef x xs = head $ last $ [x] : sortOn length (group xs)
+
+readBatteries :: BattOpts -> [Files] -> IO Result
+readBatteries opts bfs =
+ do let bfs' = filter (/= NoFiles) bfs
+ bats <- mapM (readBattery (scale opts)) (take 3 bfs')
+ ac <- haveAc (onlineFile opts)
+ let sign = if ac then 1 else -1
+ ft = sum (map full bats)
+ left = if ft > 0 then sum (map now bats) / ft else 0
+ watts = sign * sum (map power bats)
+ time = if watts == 0 then 0 else max 0 (sum $ map time' bats)
+ mwatts = if watts == 0 then 1 else sign * watts
+ time' b = (if ac then full b - now b else now b) / mwatts
+ statuses :: [Status]
+ statuses = map (fromMaybe Unknown . readMaybe)
+ (sort (map status bats))
+ acst = mostCommonDef Unknown $ filter (Unknown/=) statuses
+ racst | acst /= Unknown = acst
+ | time == 0 = Idle
+ | ac = Charging
+ | otherwise = Discharging
+ return $ if isNaN left then NA else Result left watts time racst
+
+runBatt :: [String] -> Monitor String
+runBatt = runBatt' ["BAT", "BAT0", "BAT1", "BAT2"]
+
+runBatt' :: [String] -> [String] -> Monitor String
+runBatt' bfs args = do
+ opts <- io $ parseOpts args
+ c <- io $ readBatteries opts =<< mapM batteryFiles bfs
+ suffix <- getConfigValue useSuffix
+ d <- getConfigValue decDigits
+ nas <- getConfigValue naString
+ case c of
+ Result x w t s ->
+ do l <- fmtPercent x
+ ws <- fmtWatts w opts suffix d
+ si <- getIconPattern opts s x
+ parseTemplate (l ++ [fmtStatus opts s nas, fmtTime $ floor t, ws, si])
+ NA -> getConfigValue naString
+ where fmtPercent :: Float -> Monitor [String]
+ fmtPercent x = do
+ let x' = minimum [1, x]
+ p <- showPercentWithColors x'
+ b <- showPercentBar (100 * x') x'
+ vb <- showVerticalBar (100 * x') x'
+ return [b, vb, p]
+ fmtWatts x o s d = do
+ ws <- showWithPadding $ showDigits d x ++ (if s then "W" else "")
+ return $ color x o ws
+ fmtTime :: Integer -> String
+ fmtTime x = hours ++ ":" ++ if length minutes == 2
+ then minutes else '0' : minutes
+ where hours = show (x `div` 3600)
+ minutes = show ((x `mod` 3600) `div` 60)
+ fmtStatus opts Idle _ = idleString opts
+ fmtStatus _ Unknown na = na
+ fmtStatus opts Full _ = idleString opts
+ fmtStatus opts Charging _ = onString opts
+ fmtStatus opts Discharging _ = offString opts
+ maybeColor Nothing str = str
+ maybeColor (Just c) str = "<fc=" ++ c ++ ">" ++ str ++ "</fc>"
+ color x o | x >= 0 = maybeColor (posColor o)
+ | -x >= highThreshold o = maybeColor (highWColor o)
+ | -x >= lowThreshold o = maybeColor (mediumWColor o)
+ | otherwise = maybeColor (lowWColor o)
+ getIconPattern opts st x = do
+ let x' = minimum [1, x]
+ case st of
+ Unknown -> showIconPattern (offIconPattern opts) x'
+ Idle -> showIconPattern (idleIconPattern opts) x'
+ Full -> showIconPattern (idleIconPattern opts) x'
+ Charging -> showIconPattern (onIconPattern opts) x'
+ Discharging -> showIconPattern (offIconPattern opts) x'
diff --git a/src/Xmobar/Plugins/Monitors/Bright.hs b/src/Xmobar/Plugins/Monitors/Bright.hs
new file mode 100644
index 0000000..fe72219
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Bright.hs
@@ -0,0 +1,99 @@
+-----------------------------------------------------------------------------
+---- |
+---- Module : Plugins.Monitors.Birght
+---- Copyright : (c) Martin Perner
+---- License : BSD-style (see LICENSE)
+----
+---- Maintainer : Martin Perner <martin@perner.cc>
+---- Stability : unstable
+---- Portability : unportable
+----
+---- A screen brightness monitor for Xmobar
+----
+-------------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Bright (brightConfig, runBright) where
+
+import Control.Applicative ((<$>))
+import Control.Exception (SomeException, handle)
+import qualified Data.ByteString.Lazy.Char8 as B
+import System.FilePath ((</>))
+import System.Posix.Files (fileExist)
+import System.Console.GetOpt
+
+import Xmobar.Plugins.Monitors.Common
+
+data BrightOpts = BrightOpts { subDir :: String
+ , currBright :: String
+ , maxBright :: String
+ , curBrightIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: BrightOpts
+defaultOpts = BrightOpts { subDir = "acpi_video0"
+ , currBright = "actual_brightness"
+ , maxBright = "max_brightness"
+ , curBrightIconPattern = Nothing
+ }
+
+options :: [OptDescr (BrightOpts -> BrightOpts)]
+options = [ Option "D" ["device"] (ReqArg (\x o -> o { subDir = x }) "") ""
+ , Option "C" ["curr"] (ReqArg (\x o -> o { currBright = x }) "") ""
+ , Option "M" ["max"] (ReqArg (\x o -> o { maxBright = x }) "") ""
+ , Option "" ["brightness-icon-pattern"] (ReqArg (\x o ->
+ o { curBrightIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+-- from Batt.hs
+parseOpts :: [String] -> IO BrightOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+sysDir :: FilePath
+sysDir = "/sys/class/backlight/"
+
+brightConfig :: IO MConfig
+brightConfig = mkMConfig "<percent>" -- template
+ ["vbar", "percent", "bar", "ipat"] -- replacements
+
+data Files = Files { fCurr :: String
+ , fMax :: String
+ }
+ | NoFiles
+
+brightFiles :: BrightOpts -> IO Files
+brightFiles opts = do
+ is_curr <- fileExist $ fCurr files
+ is_max <- fileExist $ fCurr files
+ return (if is_curr && is_max then files else NoFiles)
+ where prefix = sysDir </> subDir opts
+ files = Files { fCurr = prefix </> currBright opts
+ , fMax = prefix </> maxBright opts
+ }
+
+runBright :: [String] -> Monitor String
+runBright args = do
+ opts <- io $ parseOpts args
+ f <- io $ brightFiles opts
+ c <- io $ readBright f
+ case f of
+ NoFiles -> return "hurz"
+ _ -> fmtPercent opts c >>= parseTemplate
+ where fmtPercent :: BrightOpts -> Float -> Monitor [String]
+ fmtPercent opts c = do r <- showVerticalBar (100 * c) c
+ s <- showPercentWithColors c
+ t <- showPercentBar (100 * c) c
+ d <- showIconPattern (curBrightIconPattern opts) c
+ return [r,s,t,d]
+
+readBright :: Files -> IO Float
+readBright NoFiles = return 0
+readBright files = do
+ currVal<- grab $ fCurr files
+ maxVal <- grab $ fMax files
+ return (currVal / maxVal)
+ where grab f = handle handler (read . B.unpack <$> B.readFile f)
+ handler = const (return 0) :: SomeException -> IO Float
+
diff --git a/src/Xmobar/Plugins/Monitors/CatInt.hs b/src/Xmobar/Plugins/Monitors/CatInt.hs
new file mode 100644
index 0000000..781eded
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/CatInt.hs
@@ -0,0 +1,25 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.CatInt
+-- Copyright : (c) Nathaniel Wesley Filardo
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Nathaniel Wesley Filardo
+-- Stability : unstable
+-- Portability : unportable
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.CatInt where
+
+import Xmobar.Plugins.Monitors.Common
+import Xmobar.Plugins.Monitors.CoreCommon
+
+catIntConfig :: IO MConfig
+catIntConfig = mkMConfig "<v>" ["v"]
+
+runCatInt :: FilePath -> [String] -> Monitor String
+runCatInt p _ =
+ let failureMessage = "Cannot read: " ++ show p
+ fmt x = show (truncate x :: Int)
+ in checkedDataRetrieval failureMessage [[p]] Nothing id fmt
diff --git a/src/Xmobar/Plugins/Monitors/Common.hs b/src/Xmobar/Plugins/Monitors/Common.hs
new file mode 100644
index 0000000..f683874
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Common.hs
@@ -0,0 +1,545 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Common
+-- Copyright : (c) 2010, 2011, 2013, 2016, 2017, 2018 Jose Antonio Ortega Ruiz
+-- (c) 2007-2010 Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Utilities used by xmobar's monitors
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Common (
+ -- * Monitors
+ -- $monitor
+ Monitor
+ , MConfig (..)
+ , Opts (..)
+ , setConfigValue
+ , getConfigValue
+ , mkMConfig
+ , runM
+ , runMD
+ , runMB
+ , runMBD
+ , io
+ -- * Parsers
+ -- $parsers
+ , runP
+ , skipRestOfLine
+ , getNumbers
+ , getNumbersAsString
+ , getAllBut
+ , getAfterString
+ , skipTillString
+ , parseTemplate
+ , parseTemplate'
+ -- ** String Manipulation
+ -- $strings
+ , IconPattern
+ , parseIconPattern
+ , padString
+ , showWithPadding
+ , showWithColors
+ , showWithColors'
+ , showPercentWithColors
+ , showPercentsWithColors
+ , showPercentBar
+ , showVerticalBar
+ , showIconPattern
+ , showLogBar
+ , showLogVBar
+ , showLogIconPattern
+ , showWithUnits
+ , takeDigits
+ , showDigits
+ , floatToPercent
+ , parseFloat
+ , parseInt
+ , stringParser
+ ) where
+
+
+import Control.Applicative ((<$>))
+import Control.Monad.Reader
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.IORef
+import qualified Data.Map as Map
+import Data.List
+import Data.Char
+import Numeric
+import Text.ParserCombinators.Parsec
+import System.Console.GetOpt
+import Control.Exception (SomeException,handle)
+
+import Xmobar.Utils
+
+-- $monitor
+
+type Monitor a = ReaderT MConfig IO a
+
+data MConfig =
+ MC { normalColor :: IORef (Maybe String)
+ , low :: IORef Int
+ , lowColor :: IORef (Maybe String)
+ , high :: IORef Int
+ , highColor :: IORef (Maybe String)
+ , template :: IORef String
+ , export :: IORef [String]
+ , ppad :: IORef Int
+ , decDigits :: IORef Int
+ , minWidth :: IORef Int
+ , maxWidth :: IORef Int
+ , maxWidthEllipsis :: IORef String
+ , padChars :: IORef String
+ , padRight :: IORef Bool
+ , barBack :: IORef String
+ , barFore :: IORef String
+ , barWidth :: IORef Int
+ , useSuffix :: IORef Bool
+ , naString :: IORef String
+ , maxTotalWidth :: IORef Int
+ , maxTotalWidthEllipsis :: IORef String
+ }
+
+-- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState'
+type Selector a = MConfig -> IORef a
+
+sel :: Selector a -> Monitor a
+sel s =
+ do hs <- ask
+ liftIO $ readIORef (s hs)
+
+mods :: Selector a -> (a -> a) -> Monitor ()
+mods s m =
+ do v <- ask
+ io $ modifyIORef (s v) m
+
+setConfigValue :: a -> Selector a -> Monitor ()
+setConfigValue v s =
+ mods s (const v)
+
+getConfigValue :: Selector a -> Monitor a
+getConfigValue = sel
+
+mkMConfig :: String
+ -> [String]
+ -> IO MConfig
+mkMConfig tmpl exprts =
+ do lc <- newIORef Nothing
+ l <- newIORef 33
+ nc <- newIORef Nothing
+ h <- newIORef 66
+ hc <- newIORef Nothing
+ t <- newIORef tmpl
+ e <- newIORef exprts
+ p <- newIORef 0
+ d <- newIORef 0
+ mn <- newIORef 0
+ mx <- newIORef 0
+ mel <- newIORef ""
+ pc <- newIORef " "
+ pr <- newIORef False
+ bb <- newIORef ":"
+ bf <- newIORef "#"
+ bw <- newIORef 10
+ up <- newIORef False
+ na <- newIORef "N/A"
+ mt <- newIORef 0
+ mtel <- newIORef ""
+ return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel
+
+data Opts = HighColor String
+ | NormalColor String
+ | LowColor String
+ | Low String
+ | High String
+ | Template String
+ | PercentPad String
+ | DecDigits String
+ | MinWidth String
+ | MaxWidth String
+ | Width String
+ | WidthEllipsis String
+ | PadChars String
+ | PadAlign String
+ | BarBack String
+ | BarFore String
+ | BarWidth String
+ | UseSuffix String
+ | NAString String
+ | MaxTotalWidth String
+ | MaxTotalWidthEllipsis String
+
+options :: [OptDescr Opts]
+options =
+ [
+ Option "H" ["High"] (ReqArg High "number") "The high threshold"
+ , Option "L" ["Low"] (ReqArg Low "number") "The low threshold"
+ , Option "h" ["high"] (ReqArg HighColor "color number") "Color for the high threshold: ex \"#FF0000\""
+ , Option "n" ["normal"] (ReqArg NormalColor "color number") "Color for the normal threshold: ex \"#00FF00\""
+ , Option "l" ["low"] (ReqArg LowColor "color number") "Color for the low threshold: ex \"#0000FF\""
+ , Option "t" ["template"] (ReqArg Template "output template") "Output template."
+ , Option "S" ["suffix"] (ReqArg UseSuffix "True/False") "Use % to display percents or other suffixes."
+ , Option "d" ["ddigits"] (ReqArg DecDigits "decimal digits") "Number of decimal digits to display."
+ , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width."
+ , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width") "Minimum field width"
+ , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width") "Maximum field width"
+ , Option "w" ["width"] (ReqArg Width "fixed width") "Fixed field width"
+ , Option "e" ["maxwidthellipsis"] (ReqArg WidthEllipsis "Maximum width ellipsis") "Ellipsis to be added to the field when it has reached its max width."
+ , Option "c" ["padchars"] (ReqArg PadChars "padding chars") "Characters to use for padding"
+ , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right"
+ , Option "b" ["bback"] (ReqArg BarBack "bar background") "Characters used to draw bar backgrounds"
+ , Option "f" ["bfore"] (ReqArg BarFore "bar foreground") "Characters used to draw bar foregrounds"
+ , Option "W" ["bwidth"] (ReqArg BarWidth "bar width") "Bar width"
+ , Option "x" ["nastring"] (ReqArg NAString "N/A string") "String used when the monitor is not available"
+ , Option "T" ["maxtwidth"] (ReqArg MaxTotalWidth "Maximum total width") "Maximum total width"
+ , Option "E" ["maxtwidthellipsis"] (ReqArg MaxTotalWidthEllipsis "Maximum total width ellipsis") "Ellipsis to be added to the total text when it has reached its max width."
+ ]
+
+doArgs :: [String] -> ([String] -> Monitor String) -> ([String] -> Monitor Bool) -> Monitor String
+doArgs args action detect =
+ case getOpt Permute options args of
+ (o, n, []) -> do doConfigOptions o
+ ready <- detect n
+ if ready
+ then action n
+ else return "<Waiting...>"
+ (_, _, errs) -> return (concat errs)
+
+doConfigOptions :: [Opts] -> Monitor ()
+doConfigOptions [] = io $ return ()
+doConfigOptions (o:oo) =
+ do let next = doConfigOptions oo
+ nz s = let x = read s in max 0 x
+ bool = (`elem` ["True", "true", "Yes", "yes", "On", "on"])
+ (case o of
+ High h -> setConfigValue (read h) high
+ Low l -> setConfigValue (read l) low
+ HighColor c -> setConfigValue (Just c) highColor
+ NormalColor c -> setConfigValue (Just c) normalColor
+ LowColor c -> setConfigValue (Just c) lowColor
+ Template t -> setConfigValue t template
+ PercentPad p -> setConfigValue (nz p) ppad
+ DecDigits d -> setConfigValue (nz d) decDigits
+ MinWidth w -> setConfigValue (nz w) minWidth
+ MaxWidth w -> setConfigValue (nz w) maxWidth
+ Width w -> setConfigValue (nz w) minWidth >>
+ setConfigValue (nz w) maxWidth
+ WidthEllipsis e -> setConfigValue e maxWidthEllipsis
+ PadChars s -> setConfigValue s padChars
+ PadAlign a -> setConfigValue ("r" `isPrefixOf` a) padRight
+ BarBack s -> setConfigValue s barBack
+ BarFore s -> setConfigValue s barFore
+ BarWidth w -> setConfigValue (nz w) barWidth
+ UseSuffix u -> setConfigValue (bool u) useSuffix
+ NAString s -> setConfigValue s naString
+ MaxTotalWidth w -> setConfigValue (nz w) maxTotalWidth
+ MaxTotalWidthEllipsis e -> setConfigValue e maxTotalWidthEllipsis) >> next
+
+runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int
+ -> (String -> IO ()) -> IO ()
+runM args conf action r = runMB args conf action (tenthSeconds r)
+
+runMD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int
+ -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO ()
+runMD args conf action r = runMBD args conf action (tenthSeconds r)
+
+runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO ()
+ -> (String -> IO ()) -> IO ()
+runMB args conf action wait = runMBD args conf action wait (\_ -> return True)
+
+runMBD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO ()
+ -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO ()
+runMBD args conf action wait detect cb = handle (cb . showException) loop
+ where ac = doArgs args action detect
+ loop = conf >>= runReaderT ac >>= cb >> wait >> loop
+
+showException :: SomeException -> String
+showException = ("error: "++) . show . flip asTypeOf undefined
+
+io :: IO a -> Monitor a
+io = liftIO
+
+-- $parsers
+
+runP :: Parser [a] -> String -> IO [a]
+runP p i =
+ case parse p "" i of
+ Left _ -> return []
+ Right x -> return x
+
+getAllBut :: String -> Parser String
+getAllBut s =
+ manyTill (noneOf s) (char $ head s)
+
+getNumbers :: Parser Float
+getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n
+
+getNumbersAsString :: Parser String
+getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n
+
+skipRestOfLine :: Parser Char
+skipRestOfLine =
+ do many $ noneOf "\n\r"
+ newline
+
+getAfterString :: String -> Parser String
+getAfterString s =
+ do { try $ manyTill skipRestOfLine $ string s
+ ; manyTill anyChar newline
+ } <|> return ""
+
+skipTillString :: String -> Parser String
+skipTillString s =
+ manyTill skipRestOfLine $ string s
+
+-- | Parses the output template string
+templateStringParser :: Parser (String,String,String)
+templateStringParser =
+ do { s <- nonPlaceHolder
+ ; com <- templateCommandParser
+ ; ss <- nonPlaceHolder
+ ; return (s, com, ss)
+ }
+ where
+ nonPlaceHolder = fmap concat . many $
+ many1 (noneOf "<") <|> colorSpec <|> iconSpec
+
+-- | Recognizes color specification and returns it unchanged
+colorSpec :: Parser String
+colorSpec = try (string "</fc>") <|> try (
+ do string "<fc="
+ s <- many1 (alphaNum <|> char ',' <|> char '#')
+ char '>'
+ return $ "<fc=" ++ s ++ ">")
+
+-- | Recognizes icon specification and returns it unchanged
+iconSpec :: Parser String
+iconSpec = try (do string "<icon="
+ i <- manyTill (noneOf ">") (try (string "/>"))
+ return $ "<icon=" ++ i ++ "/>")
+
+-- | Parses the command part of the template string
+templateCommandParser :: Parser String
+templateCommandParser =
+ do { char '<'
+ ; com <- many $ noneOf ">"
+ ; char '>'
+ ; return com
+ }
+
+-- | Combines the template parsers
+templateParser :: Parser [(String,String,String)]
+templateParser = many templateStringParser --"%")
+
+trimTo :: Int -> String -> String -> (Int, String)
+trimTo n p "" = (n, p)
+trimTo n p ('<':cs) = trimTo n p' s
+ where p' = p ++ "<" ++ takeWhile (/= '>') cs ++ ">"
+ s = drop 1 (dropWhile (/= '>') cs)
+trimTo 0 p s = trimTo 0 p (dropWhile (/= '<') s)
+trimTo n p s = let p' = takeWhile (/= '<') s
+ s' = dropWhile (/= '<') s
+ in
+ if length p' <= n
+ then trimTo (n - length p') (p ++ p') s'
+ else trimTo 0 (p ++ take n p') s'
+
+-- | Takes a list of strings that represent the values of the exported
+-- keys. The strings are joined with the exported keys to form a map
+-- to be combined with 'combine' to the parsed template. Returns the
+-- final output of the monitor, trimmed to MaxTotalWidth if that
+-- configuration value is positive.
+parseTemplate :: [String] -> Monitor String
+parseTemplate l =
+ do t <- getConfigValue template
+ e <- getConfigValue export
+ w <- getConfigValue maxTotalWidth
+ ell <- getConfigValue maxTotalWidthEllipsis
+ let m = Map.fromList . zip e $ l
+ s <- parseTemplate' t m
+ let (n, s') = if w > 0 && length s > w
+ then trimTo (w - length ell) "" s
+ else (1, s)
+ return $ if n > 0 then s' else s' ++ ell
+
+-- | Parses the template given to it with a map of export values and combines
+-- them
+parseTemplate' :: String -> Map.Map String String -> Monitor String
+parseTemplate' t m =
+ do s <- io $ runP templateParser t
+ combine m s
+
+-- | Given a finite "Map" and a parsed template t produces the
+-- | resulting output string as the output of the monitor.
+combine :: Map.Map String String -> [(String, String, String)] -> Monitor String
+combine _ [] = return []
+combine m ((s,ts,ss):xs) =
+ do next <- combine m xs
+ str <- case Map.lookup ts m of
+ Nothing -> return $ "<" ++ ts ++ ">"
+ Just r -> let f "" = r; f n = n; in f <$> parseTemplate' r m
+ return $ s ++ str ++ ss ++ next
+
+-- $strings
+
+type IconPattern = Int -> String
+
+parseIconPattern :: String -> IconPattern
+parseIconPattern path =
+ let spl = splitOnPercent path
+ in \i -> intercalate (show i) spl
+ where splitOnPercent [] = [[]]
+ splitOnPercent ('%':'%':xs) = [] : splitOnPercent xs
+ splitOnPercent (x:xs) =
+ let rest = splitOnPercent xs
+ in (x : head rest) : tail rest
+
+type Pos = (Int, Int)
+
+takeDigits :: Int -> Float -> Float
+takeDigits d n =
+ fromIntegral (round (n * fact) :: Int) / fact
+ where fact = 10 ^ d
+
+showDigits :: (RealFloat a) => Int -> a -> String
+showDigits d n = showFFloat (Just d) n ""
+
+showWithUnits :: Int -> Int -> Float -> String
+showWithUnits d n x
+ | x < 0 = '-' : showWithUnits d n (-x)
+ | n > 3 || x < 10^(d + 1) = show (round x :: Int) ++ units n
+ | x <= 1024 = showDigits d (x/1024) ++ units (n+1)
+ | otherwise = showWithUnits d (n+1) (x/1024)
+ where units = (!!) ["B", "K", "M", "G", "T"]
+
+padString :: Int -> Int -> String -> Bool -> String -> String -> String
+padString mnw mxw pad pr ellipsis s =
+ let len = length s
+ rmin = if mnw <= 0 then 1 else mnw
+ rmax = if mxw <= 0 then max len rmin else mxw
+ (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin)
+ rlen = min (max rmn len) rmx
+ in if rlen < len then
+ take rlen s ++ ellipsis
+ else let ps = take (rlen - len) (cycle pad)
+ in if pr then s ++ ps else ps ++ s
+
+parseFloat :: String -> Float
+parseFloat s = case readFloat s of
+ (v, _):_ -> v
+ _ -> 0
+
+parseInt :: String -> Int
+parseInt s = case readDec s of
+ (v, _):_ -> v
+ _ -> 0
+
+floatToPercent :: Float -> Monitor String
+floatToPercent n =
+ do pad <- getConfigValue ppad
+ pc <- getConfigValue padChars
+ pr <- getConfigValue padRight
+ up <- getConfigValue useSuffix
+ let p = showDigits 0 (n * 100)
+ ps = if up then "%" else ""
+ return $ padString pad pad pc pr "" p ++ ps
+
+stringParser :: Pos -> B.ByteString -> String
+stringParser (x,y) =
+ B.unpack . li x . B.words . li y . B.lines
+ where li i l | length l > i = l !! i
+ | otherwise = B.empty
+
+setColor :: String -> Selector (Maybe String) -> Monitor String
+setColor str s =
+ do a <- getConfigValue s
+ case a of
+ Nothing -> return str
+ Just c -> return $
+ "<fc=" ++ c ++ ">" ++ str ++ "</fc>"
+
+showWithPadding :: String -> Monitor String
+showWithPadding s =
+ do mn <- getConfigValue minWidth
+ mx <- getConfigValue maxWidth
+ p <- getConfigValue padChars
+ pr <- getConfigValue padRight
+ ellipsis <- getConfigValue maxWidthEllipsis
+ return $ padString mn mx p pr ellipsis s
+
+colorizeString :: (Num a, Ord a) => a -> String -> Monitor String
+colorizeString x s = do
+ h <- getConfigValue high
+ l <- getConfigValue low
+ let col = setColor s
+ [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low
+ head $ [col highColor | x > hh ] ++
+ [col normalColor | x > ll ] ++
+ [col lowColor | True]
+
+showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String
+showWithColors f x = showWithPadding (f x) >>= colorizeString x
+
+showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String
+showWithColors' str = showWithColors (const str)
+
+showPercentsWithColors :: [Float] -> Monitor [String]
+showPercentsWithColors fs =
+ do fstrs <- mapM floatToPercent fs
+ zipWithM (showWithColors . const) fstrs (map (*100) fs)
+
+showPercentWithColors :: Float -> Monitor String
+showPercentWithColors f = fmap head $ showPercentsWithColors [f]
+
+showPercentBar :: Float -> Float -> Monitor String
+showPercentBar v x = do
+ bb <- getConfigValue barBack
+ bf <- getConfigValue barFore
+ bw <- getConfigValue barWidth
+ let len = min bw $ round (fromIntegral bw * x)
+ s <- colorizeString v (take len $ cycle bf)
+ return $ s ++ take (bw - len) (cycle bb)
+
+showIconPattern :: Maybe IconPattern -> Float -> Monitor String
+showIconPattern Nothing _ = return ""
+showIconPattern (Just str) x = return $ str $ convert $ 100 * x
+ where convert val
+ | t <= 0 = 0
+ | t > 8 = 8
+ | otherwise = t
+ where t = round val `div` 12
+
+showVerticalBar :: Float -> Float -> Monitor String
+showVerticalBar v x = colorizeString v [convert $ 100 * x]
+ where convert :: Float -> Char
+ convert val
+ | t <= 9600 = ' '
+ | t > 9608 = chr 9608
+ | otherwise = chr t
+ where t = 9600 + (round val `div` 12)
+
+logScaling :: Float -> Float -> Monitor Float
+logScaling f v = do
+ h <- fromIntegral `fmap` getConfigValue high
+ l <- fromIntegral `fmap` getConfigValue low
+ bw <- fromIntegral `fmap` getConfigValue barWidth
+ let [ll, hh] = sort [l, h]
+ scaled x | x == 0.0 = 0
+ | x <= ll = 1 / bw
+ | otherwise = f + logBase 2 (x / hh) / bw
+ return $ scaled v
+
+showLogBar :: Float -> Float -> Monitor String
+showLogBar f v = logScaling f v >>= showPercentBar v
+
+showLogVBar :: Float -> Float -> Monitor String
+showLogVBar f v = logScaling f v >>= showVerticalBar v
+
+showLogIconPattern :: Maybe IconPattern -> Float -> Float -> Monitor String
+showLogIconPattern str f v = logScaling f v >>= showIconPattern str
diff --git a/src/Xmobar/Plugins/Monitors/CoreCommon.hs b/src/Xmobar/Plugins/Monitors/CoreCommon.hs
new file mode 100644
index 0000000..a84198e
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/CoreCommon.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE CPP, PatternGuards #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.CoreCommon
+-- Copyright : (c) Juraj Hercek
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- The common part for cpu core monitors (e.g. cpufreq, coretemp)
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.CoreCommon where
+
+#if __GLASGOW_HASKELL__ < 800
+import Control.Applicative
+#endif
+
+import Data.Char hiding (Space)
+import Data.Function
+import Data.List
+import Data.Maybe
+import Xmobar.Plugins.Monitors.Common
+import System.Directory
+
+checkedDataRetrieval :: (Ord a, Num a)
+ => String -> [[String]] -> Maybe (String, String -> Int)
+ -> (Double -> a) -> (a -> String) -> Monitor String
+checkedDataRetrieval msg paths lbl trans fmt =
+ fmap (fromMaybe msg . listToMaybe . catMaybes) $
+ mapM (\p -> retrieveData p lbl trans fmt) paths
+
+retrieveData :: (Ord a, Num a)
+ => [String] -> Maybe (String, String -> Int)
+ -> (Double -> a) -> (a -> String) -> Monitor (Maybe String)
+retrieveData path lbl trans fmt = do
+ pairs <- map snd . sortBy (compare `on` fst) <$>
+ (mapM readFiles =<< findFilesAndLabel path lbl)
+ if null pairs
+ then return Nothing
+ else Just <$> ( parseTemplate
+ =<< mapM (showWithColors fmt . trans . read) pairs
+ )
+
+-- | Represents the different types of path components
+data Comp = Fix String
+ | Var [String]
+ deriving Show
+
+-- | Used to represent parts of file names separated by slashes and spaces
+data CompOrSep = Slash
+ | Space
+ | Comp String
+ deriving (Eq, Show)
+
+-- | Function to turn a list of of strings into a list of path components
+pathComponents :: [String] -> [Comp]
+pathComponents = joinComps . drop 2 . intercalate [Space] . map splitParts
+ where
+ splitParts p | (l, _:r) <- break (== '/') p = Comp l : Slash : splitParts r
+ | otherwise = [Comp p]
+
+ joinComps = uncurry joinComps' . partition isComp
+
+ isComp (Comp _) = True
+ isComp _ = False
+
+ fromComp (Comp s) = s
+ fromComp _ = error "fromComp applied to value other than (Comp _)"
+
+ joinComps' cs [] = [Fix $ fromComp $ head cs] -- cs should have only one element here,
+ -- but this keeps the pattern matching
+ -- exhaustive
+ joinComps' cs (p:ps) = let (ss, ps') = span (== p) ps
+ ct = if null ps' || (p == Space) then length ss + 1
+ else length ss
+ (ls, rs) = splitAt (ct+1) cs
+ c = case p of
+ Space -> Var $ map fromComp ls
+ Slash -> Fix $ intercalate "/" $ map fromComp ls
+ _ -> error "Should not happen"
+ in if null ps' then [c]
+ else c:joinComps' rs (drop ct ps)
+
+-- | Function to find all files matching the given path and possible label file.
+-- The path must be absolute (start with a leading slash).
+findFilesAndLabel :: [String] -> Maybe (String, String -> Int)
+ -> Monitor [(String, Either Int (String, String -> Int))]
+findFilesAndLabel path lbl = catMaybes
+ <$> ( mapM addLabel . zip [0..] . sort
+ =<< recFindFiles (pathComponents path) "/"
+ )
+ where
+ addLabel (i, f) = maybe (return $ Just (f, Left i))
+ (uncurry (justIfExists f))
+ lbl
+
+ justIfExists f s t = let f' = take (length f - length s) f ++ s
+ in ifthen (Just (f, Right (f', t))) Nothing <$> io (doesFileExist f')
+
+ recFindFiles [] d = ifthen [d] []
+ <$> io (if null d then return False else doesFileExist d)
+ recFindFiles ps d = ifthen (recFindFiles' ps d) (return [])
+ =<< io (if null d then return True else doesDirectoryExist d)
+
+ recFindFiles' [] _ = error "Should not happen"
+ recFindFiles' (Fix p:ps) d = recFindFiles ps (d ++ "/" ++ p)
+ recFindFiles' (Var p:ps) d = concat
+ <$> ((mapM (recFindFiles ps
+ . (\f -> d ++ "/" ++ f))
+ . filter (matchesVar p))
+ =<< io (getDirectoryContents d)
+ )
+
+ matchesVar [] _ = False
+ matchesVar [v] f = v == f
+ matchesVar (v:vs) f = let f' = drop (length v) f
+ f'' = dropWhile isDigit f'
+ in and [ v `isPrefixOf` f
+ , not (null f')
+ , isDigit (head f')
+ , matchesVar vs f''
+ ]
+
+-- | Function to read the contents of the given file(s)
+readFiles :: (String, Either Int (String, String -> Int))
+ -> Monitor (Int, String)
+readFiles (fval, flbl) = (,) <$> either return (\(f, ex) -> fmap ex
+ $ io $ readFile f) flbl
+ <*> io (readFile fval)
+
+-- | Function that captures if-then-else
+ifthen :: a -> a -> Bool -> a
+ifthen thn els cnd = if cnd then thn else els
diff --git a/src/Xmobar/Plugins/Monitors/CoreTemp.hs b/src/Xmobar/Plugins/Monitors/CoreTemp.hs
new file mode 100644
index 0000000..48fe428
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/CoreTemp.hs
@@ -0,0 +1,45 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.CoreTemp
+-- Copyright : (c) Juraj Hercek
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A core temperature monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.CoreTemp where
+
+import Xmobar.Plugins.Monitors.Common
+import Xmobar.Plugins.Monitors.CoreCommon
+
+
+import Data.Char (isDigit)
+
+-- |
+-- Core temperature default configuration. Default template contains only one
+-- core temperature, user should specify custom template in order to get more
+-- core frequencies.
+coreTempConfig :: IO MConfig
+coreTempConfig = mkMConfig
+ "Temp: <core0>C" -- template
+ (map ((++) "core" . show) [0 :: Int ..]) -- available
+ -- replacements
+
+-- |
+-- Function retrieves monitor string holding the core temperature
+-- (or temperatures)
+runCoreTemp :: [String] -> Monitor String
+runCoreTemp _ = do
+ dn <- getConfigValue decDigits
+ failureMessage <- getConfigValue naString
+ let path = ["/sys/bus/platform/devices/coretemp.", "/temp", "_input"]
+ path' = ["/sys/bus/platform/devices/coretemp.", "/hwmon/hwmon", "/temp", "_input"]
+ lbl = Just ("_label", read . dropWhile (not . isDigit))
+ divisor = 1e3 :: Double
+ show' = showDigits (max 0 dn)
+ checkedDataRetrieval failureMessage [path, path'] lbl (/divisor) show'
diff --git a/src/Xmobar/Plugins/Monitors/Cpu.hs b/src/Xmobar/Plugins/Monitors/Cpu.hs
new file mode 100644
index 0000000..6befe7d
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Cpu.hs
@@ -0,0 +1,88 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Cpu
+-- Copyright : (c) 2011, 2017 Jose Antonio Ortega Ruiz
+-- (c) 2007-2010 Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A cpu monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Cpu (startCpu) where
+
+import Xmobar.Plugins.Monitors.Common
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import System.Console.GetOpt
+
+newtype CpuOpts = CpuOpts
+ { loadIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: CpuOpts
+defaultOpts = CpuOpts
+ { loadIconPattern = Nothing
+ }
+
+options :: [OptDescr (CpuOpts -> CpuOpts)]
+options =
+ [ Option "" ["load-icon-pattern"] (ReqArg (\x o ->
+ o { loadIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+parseOpts :: [String] -> IO CpuOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+cpuConfig :: IO MConfig
+cpuConfig = mkMConfig
+ "Cpu: <total>%"
+ ["bar","vbar","ipat","total","user","nice","system","idle","iowait"]
+
+type CpuDataRef = IORef [Int]
+
+cpuData :: IO [Int]
+cpuData = cpuParser `fmap` B.readFile "/proc/stat"
+
+cpuParser :: B.ByteString -> [Int]
+cpuParser = map (read . B.unpack) . tail . B.words . head . B.lines
+
+parseCpu :: CpuDataRef -> IO [Float]
+parseCpu cref =
+ do a <- readIORef cref
+ b <- cpuData
+ writeIORef cref b
+ let dif = zipWith (-) b a
+ tot = fromIntegral $ sum dif
+ percent = map ((/ tot) . fromIntegral) dif
+ return percent
+
+formatCpu :: CpuOpts -> [Float] -> Monitor [String]
+formatCpu _ [] = return $ replicate 8 ""
+formatCpu opts xs = do
+ let t = sum $ take 3 xs
+ b <- showPercentBar (100 * t) t
+ v <- showVerticalBar (100 * t) t
+ d <- showIconPattern (loadIconPattern opts) t
+ ps <- showPercentsWithColors (t:xs)
+ return (b:v:d:ps)
+
+runCpu :: CpuDataRef -> [String] -> Monitor String
+runCpu cref argv =
+ do c <- io (parseCpu cref)
+ opts <- io $ parseOpts argv
+ l <- formatCpu opts c
+ parseTemplate l
+
+startCpu :: [String] -> Int -> (String -> IO ()) -> IO ()
+startCpu a r cb = do
+ cref <- newIORef []
+ _ <- parseCpu cref
+ runM a cpuConfig (runCpu cref) r cb
diff --git a/src/Xmobar/Plugins/Monitors/CpuFreq.hs b/src/Xmobar/Plugins/Monitors/CpuFreq.hs
new file mode 100644
index 0000000..1afedfa
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/CpuFreq.hs
@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.CpuFreq
+-- Copyright : (c) Juraj Hercek
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A cpu frequency monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.CpuFreq where
+
+import Xmobar.Plugins.Monitors.Common
+import Xmobar.Plugins.Monitors.CoreCommon
+
+-- |
+-- Cpu frequency default configuration. Default template contains only
+-- one core frequency, user should specify custom template in order to
+-- get more cpu frequencies.
+cpuFreqConfig :: IO MConfig
+cpuFreqConfig =
+ mkMConfig "Freq: <cpu0>" (map ((++) "cpu" . show) [0 :: Int ..])
+
+
+-- |
+-- Function retrieves monitor string holding the cpu frequency (or
+-- frequencies)
+runCpuFreq :: [String] -> Monitor String
+runCpuFreq _ = do
+ suffix <- getConfigValue useSuffix
+ ddigits <- getConfigValue decDigits
+ let path = ["/sys/devices/system/cpu/cpu", "/cpufreq/scaling_cur_freq"]
+ divisor = 1e6 :: Double
+ fmt x | x < 1 = if suffix then mhzFmt x ++ "MHz"
+ else ghzFmt x
+ | otherwise = ghzFmt x ++ if suffix then "GHz" else ""
+ mhzFmt x = show (round (x * 1000) :: Integer)
+ ghzFmt = showDigits ddigits
+ failureMessage <- getConfigValue naString
+ checkedDataRetrieval failureMessage [path] Nothing (/divisor) fmt
diff --git a/src/Xmobar/Plugins/Monitors/Disk.hs b/src/Xmobar/Plugins/Monitors/Disk.hs
new file mode 100644
index 0000000..3f89629
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Disk.hs
@@ -0,0 +1,241 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Disk
+-- Copyright : (c) 2010, 2011, 2012, 2014, 2018 Jose A Ortega Ruiz
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Disk usage and throughput monitors for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where
+
+import Xmobar.Plugins.Monitors.Common
+import Xmobar.System.StatFS
+
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+
+import Control.Exception (SomeException, handle)
+import Control.Monad (zipWithM)
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.List (isPrefixOf, find)
+import Data.Maybe (catMaybes)
+import System.Directory (canonicalizePath, doesFileExist)
+import System.Console.GetOpt
+
+data DiskIOOpts = DiskIOOpts
+ { totalIconPattern :: Maybe IconPattern
+ , writeIconPattern :: Maybe IconPattern
+ , readIconPattern :: Maybe IconPattern
+ }
+
+parseDiskIOOpts :: [String] -> IO DiskIOOpts
+parseDiskIOOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+ where defaultOpts = DiskIOOpts
+ { totalIconPattern = Nothing
+ , writeIconPattern = Nothing
+ , readIconPattern = Nothing
+ }
+ options =
+ [ Option "" ["total-icon-pattern"] (ReqArg (\x o ->
+ o { totalIconPattern = Just $ parseIconPattern x}) "") ""
+ , Option "" ["write-icon-pattern"] (ReqArg (\x o ->
+ o { writeIconPattern = Just $ parseIconPattern x}) "") ""
+ , Option "" ["read-icon-pattern"] (ReqArg (\x o ->
+ o { readIconPattern = Just $ parseIconPattern x}) "") ""
+ ]
+
+diskIOConfig :: IO MConfig
+diskIOConfig = mkMConfig "" ["total", "read", "write"
+ ,"totalbar", "readbar", "writebar"
+ ,"totalvbar", "readvbar", "writevbar"
+ ,"totalipat", "readipat", "writeipat"
+ ]
+
+data DiskUOpts = DiskUOpts
+ { freeIconPattern :: Maybe IconPattern
+ , usedIconPattern :: Maybe IconPattern
+ }
+
+parseDiskUOpts :: [String] -> IO DiskUOpts
+parseDiskUOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+ where defaultOpts = DiskUOpts
+ { freeIconPattern = Nothing
+ , usedIconPattern = Nothing
+ }
+ options =
+ [ Option "" ["free-icon-pattern"] (ReqArg (\x o ->
+ o { freeIconPattern = Just $ parseIconPattern x}) "") ""
+ , Option "" ["used-icon-pattern"] (ReqArg (\x o ->
+ o { usedIconPattern = Just $ parseIconPattern x}) "") ""
+ ]
+
+diskUConfig :: IO MConfig
+diskUConfig = mkMConfig ""
+ [ "size", "free", "used", "freep", "usedp"
+ , "freebar", "freevbar", "freeipat"
+ , "usedbar", "usedvbar", "usedipat"
+ ]
+
+type DevName = String
+type Path = String
+type DevDataRef = IORef [(DevName, [Float])]
+
+mountedDevices :: [String] -> IO [(DevName, Path)]
+mountedDevices req = do
+ s <- B.readFile "/etc/mtab"
+ parse `fmap` mapM mbcanon (devs s)
+ where
+ mbcanon (d, p) = doesFileExist d >>= \e ->
+ if e
+ then Just `fmap` canon (d,p)
+ else return Nothing
+ canon (d, p) = do {d' <- canonicalizePath d; return (d', p)}
+ devs = filter isDev . map (firstTwo . B.words) . B.lines
+ parse = map undev . filter isReq . catMaybes
+ firstTwo (a:b:_) = (B.unpack a, B.unpack b)
+ firstTwo _ = ("", "")
+ isDev (d, _) = "/dev/" `isPrefixOf` d
+ isReq (d, p) = p `elem` req || drop 5 d `elem` req
+ undev (d, f) = (drop 5 d, f)
+
+diskDevices :: [String] -> IO [(DevName, Path)]
+diskDevices req = do
+ s <- B.readFile "/proc/diskstats"
+ parse `fmap` mapM canon (devs s)
+ where
+ canon (d, p) = do {d' <- canonicalizePath d; return (d', p)}
+ devs = map (third . B.words) . B.lines
+ parse = map undev . filter isReq
+ third (_:_:c:_) = ("/dev/" ++ B.unpack c, B.unpack c)
+ third _ = ("", "")
+ isReq (d, p) = p `elem` req || drop 5 d `elem` req
+ undev (d, f) = (drop 5 d, f)
+
+mountedOrDiskDevices :: [String] -> IO [(DevName, Path)]
+mountedOrDiskDevices req = do
+ mnt <- mountedDevices req
+ case mnt of
+ [] -> diskDevices req
+ other -> return other
+
+diskData :: IO [(DevName, [Float])]
+diskData = do
+ s <- B.readFile "/proc/diskstats"
+ let extract ws = (head ws, map read (tail ws))
+ return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s)
+
+mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])]
+mountedData dref devs = do
+ dt <- readIORef dref
+ dt' <- diskData
+ writeIORef dref dt'
+ return $ map (parseDev (zipWith diff dt' dt)) devs
+ where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys)
+
+parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float])
+parseDev dat dev =
+ case find ((==dev) . fst) dat of
+ Nothing -> (dev, [0, 0, 0])
+ Just (_, xs) ->
+ let rSp = speed (xs !! 2) (xs !! 3)
+ wSp = speed (xs !! 6) (xs !! 7)
+ sp = speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7)
+ speed x t = if t == 0 then 0 else 500 * x / t
+ dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0]
+ in (dev, dat')
+
+speedToStr :: Float -> String
+speedToStr = showWithUnits 2 1
+
+sizeToStr :: Integer -> String
+sizeToStr = showWithUnits 3 0 . fromIntegral
+
+findTempl :: DevName -> Path -> [(String, String)] -> String
+findTempl dev path disks =
+ case find devOrPath disks of
+ Just (_, t) -> t
+ Nothing -> ""
+ where devOrPath (d, _) = d == dev || d == path
+
+devTemplates :: [(String, String)]
+ -> [(DevName, Path)]
+ -> [(DevName, [Float])]
+ -> [(String, [Float])]
+devTemplates disks mounted dat =
+ map (\(d, p) -> (findTempl d p disks, findData d)) mounted
+ where findData dev = case find ((==dev) . fst) dat of
+ Nothing -> [0, 0, 0]
+ Just (_, xs) -> xs
+
+runDiskIO' :: DiskIOOpts -> (String, [Float]) -> Monitor String
+runDiskIO' opts (tmp, xs) = do
+ s <- mapM (showWithColors speedToStr) xs
+ b <- mapM (showLogBar 0.8) xs
+ vb <- mapM (showLogVBar 0.8) xs
+ ipat <- mapM (\(f,v) -> showLogIconPattern (f opts) 0.8 v)
+ $ zip [totalIconPattern, readIconPattern, writeIconPattern] xs
+ setConfigValue tmp template
+ parseTemplate $ s ++ b ++ vb ++ ipat
+
+runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String
+runDiskIO dref disks argv = do
+ opts <- io $ parseDiskIOOpts argv
+ dev <- io $ mountedOrDiskDevices (map fst disks)
+ dat <- io $ mountedData dref (map fst dev)
+ strs <- mapM (runDiskIO' opts) $ devTemplates disks dev dat
+ return $ unwords strs
+
+startDiskIO :: [(String, String)] ->
+ [String] -> Int -> (String -> IO ()) -> IO ()
+startDiskIO disks args rate cb = do
+ dev <- mountedOrDiskDevices (map fst disks)
+ dref <- newIORef (map (\d -> (fst d, repeat 0)) dev)
+ _ <- mountedData dref (map fst dev)
+ runM args diskIOConfig (runDiskIO dref disks) rate cb
+
+fsStats :: String -> IO [Integer]
+fsStats path = do
+ stats <- getFileSystemStats path
+ case stats of
+ Nothing -> return [0, 0, 0]
+ Just f -> let tot = fsStatByteCount f
+ free = fsStatBytesAvailable f
+ used = fsStatBytesUsed f
+ in return [tot, free, used]
+
+runDiskU' :: DiskUOpts -> String -> String -> Monitor String
+runDiskU' opts tmp path = do
+ setConfigValue tmp template
+ [total, free, diff] <- io (handle ign $ fsStats path)
+ let strs = map sizeToStr [free, diff]
+ freep = if total > 0 then free * 100 `div` total else 0
+ fr = fromIntegral freep / 100
+ s <- zipWithM showWithColors' strs [freep, 100 - freep]
+ sp <- showPercentsWithColors [fr, 1 - fr]
+ fb <- showPercentBar (fromIntegral freep) fr
+ fvb <- showVerticalBar (fromIntegral freep) fr
+ fipat <- showIconPattern (freeIconPattern opts) fr
+ ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr)
+ uvb <- showVerticalBar (fromIntegral $ 100 - freep) (1 - fr)
+ uipat <- showIconPattern (usedIconPattern opts) (1 - fr)
+ parseTemplate $ [sizeToStr total] ++ s ++ sp ++ [fb,fvb,fipat,ub,uvb,uipat]
+ where ign = const (return [0, 0, 0]) :: SomeException -> IO [Integer]
+
+
+runDiskU :: [(String, String)] -> [String] -> Monitor String
+runDiskU disks argv = do
+ devs <- io $ mountedDevices (map fst disks)
+ opts <- io $ parseDiskUOpts argv
+ strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs
+ return $ unwords strs
diff --git a/src/Xmobar/Plugins/Monitors/MPD.hs b/src/Xmobar/Plugins/Monitors/MPD.hs
new file mode 100644
index 0000000..9525254
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/MPD.hs
@@ -0,0 +1,139 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.MPD
+-- Copyright : (c) Jose A Ortega Ruiz
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- MPD status and song
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait, mpdReady ) where
+
+import Data.List
+import Data.Maybe (fromMaybe)
+import Xmobar.Plugins.Monitors.Common
+import System.Console.GetOpt
+import qualified Network.MPD as M
+import Control.Concurrent (threadDelay)
+
+mpdConfig :: IO MConfig
+mpdConfig = mkMConfig "MPD: <state>"
+ [ "bar", "vbar", "ipat", "state", "statei", "volume", "length"
+ , "lapsed", "remaining", "plength", "ppos", "flags", "file"
+ , "name", "artist", "composer", "performer"
+ , "album", "title", "track", "genre", "date"
+ ]
+
+data MOpts = MOpts
+ { mPlaying :: String
+ , mStopped :: String
+ , mPaused :: String
+ , mLapsedIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: MOpts
+defaultOpts = MOpts
+ { mPlaying = ">>"
+ , mStopped = "><"
+ , mPaused = "||"
+ , mLapsedIconPattern = Nothing
+ }
+
+options :: [OptDescr (MOpts -> MOpts)]
+options =
+ [ Option "P" ["playing"] (ReqArg (\x o -> o { mPlaying = x }) "") ""
+ , Option "S" ["stopped"] (ReqArg (\x o -> o { mStopped = x }) "") ""
+ , Option "Z" ["paused"] (ReqArg (\x o -> o { mPaused = x }) "") ""
+ , Option "" ["lapsed-icon-pattern"] (ReqArg (\x o ->
+ o { mLapsedIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+runMPD :: [String] -> Monitor String
+runMPD args = do
+ opts <- io $ mopts args
+ status <- io $ M.withMPD M.status
+ song <- io $ M.withMPD M.currentSong
+ s <- parseMPD status song opts
+ parseTemplate s
+
+mpdWait :: IO ()
+mpdWait = do
+ status <- M.withMPD $ M.idle [M.PlayerS, M.MixerS, M.OptionsS]
+ case status of
+ Left _ -> threadDelay 10000000
+ _ -> return ()
+
+mpdReady :: [String] -> Monitor Bool
+mpdReady _ = do
+ response <- io $ M.withMPD M.ping
+ case response of
+ Right _ -> return True
+ -- Only cases where MPD isn't responding is an issue; bogus information at
+ -- least won't hold xmobar up.
+ Left M.NoMPD -> return False
+ Left (M.ConnectionError _) -> return False
+ Left _ -> return True
+
+mopts :: [String] -> IO MOpts
+mopts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+parseMPD :: M.Response M.Status -> M.Response (Maybe M.Song) -> MOpts
+ -> Monitor [String]
+parseMPD (Left e) _ _ = return $ show e:replicate 19 ""
+parseMPD (Right st) song opts = do
+ songData <- parseSong song
+ bar <- showPercentBar (100 * b) b
+ vbar <- showVerticalBar (100 * b) b
+ ipat <- showIconPattern (mLapsedIconPattern opts) b
+ return $ [bar, vbar, ipat, ss, si, vol, len, lap, remain, plen, ppos, flags] ++ songData
+ where s = M.stState st
+ ss = show s
+ si = stateGlyph s opts
+ vol = int2str $ fromMaybe 0 (M.stVolume st)
+ (p, t) = fromMaybe (0, 0) (M.stTime st)
+ [lap, len, remain] = map showTime [floor p, t, max 0 (t - floor p)]
+ b = if t > 0 then realToFrac $ p / fromIntegral t else 0
+ plen = int2str $ M.stPlaylistLength st
+ ppos = maybe "" (int2str . (+1)) $ M.stSongPos st
+ flags = playbackMode st
+
+stateGlyph :: M.State -> MOpts -> String
+stateGlyph s o =
+ case s of
+ M.Playing -> mPlaying o
+ M.Paused -> mPaused o
+ M.Stopped -> mStopped o
+
+playbackMode :: M.Status -> String
+playbackMode s =
+ concat [if p s then f else "-" |
+ (p,f) <- [(M.stRepeat,"r"),
+ (M.stRandom,"z"),
+ (M.stSingle,"s"),
+ (M.stConsume,"c")]]
+
+parseSong :: M.Response (Maybe M.Song) -> Monitor [String]
+parseSong (Left _) = return $ repeat ""
+parseSong (Right Nothing) = return $ repeat ""
+parseSong (Right (Just s)) =
+ let str sel = maybe "" (intercalate ", " . map M.toString) (M.sgGetTag sel s)
+ sels = [ M.Name, M.Artist, M.Composer, M.Performer
+ , M.Album, M.Title, M.Track, M.Genre, M.Date ]
+ fields = M.toString (M.sgFilePath s) : map str sels
+ in mapM showWithPadding fields
+
+showTime :: Integer -> String
+showTime t = int2str minutes ++ ":" ++ int2str seconds
+ where minutes = t `div` 60
+ seconds = t `mod` 60
+
+int2str :: (Show a, Num a, Ord a) => a -> String
+int2str x = if x < 10 then '0':sx else sx where sx = show x
diff --git a/src/Xmobar/Plugins/Monitors/Mem.hs b/src/Xmobar/Plugins/Monitors/Mem.hs
new file mode 100644
index 0000000..d69921b
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Mem.hs
@@ -0,0 +1,96 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Mem
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A memory monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where
+
+import Xmobar.Plugins.Monitors.Common
+import qualified Data.Map as M
+import System.Console.GetOpt
+
+data MemOpts = MemOpts
+ { usedIconPattern :: Maybe IconPattern
+ , freeIconPattern :: Maybe IconPattern
+ , availableIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: MemOpts
+defaultOpts = MemOpts
+ { usedIconPattern = Nothing
+ , freeIconPattern = Nothing
+ , availableIconPattern = Nothing
+ }
+
+options :: [OptDescr (MemOpts -> MemOpts)]
+options =
+ [ Option "" ["used-icon-pattern"] (ReqArg (\x o ->
+ o { usedIconPattern = Just $ parseIconPattern x }) "") ""
+ , Option "" ["free-icon-pattern"] (ReqArg (\x o ->
+ o { freeIconPattern = Just $ parseIconPattern x }) "") ""
+ , Option "" ["available-icon-pattern"] (ReqArg (\x o ->
+ o { availableIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+parseOpts :: [String] -> IO MemOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+memConfig :: IO MConfig
+memConfig = mkMConfig
+ "Mem: <usedratio>% (<cache>M)" -- template
+ ["usedbar", "usedvbar", "usedipat", "freebar", "freevbar", "freeipat",
+ "availablebar", "availablevbar", "availableipat",
+ "usedratio", "freeratio", "availableratio",
+ "total", "free", "buffer", "cache", "available", "used"] -- available replacements
+
+fileMEM :: IO String
+fileMEM = readFile "/proc/meminfo"
+
+parseMEM :: IO [Float]
+parseMEM =
+ do file <- fileMEM
+ let content = map words $ take 8 $ lines file
+ info = M.fromList $ map (\line -> (head line, (read $ line !! 1 :: Float) / 1024)) content
+ [total, free, buffer, cache] = map (info M.!) ["MemTotal:", "MemFree:", "Buffers:", "Cached:"]
+ available = M.findWithDefault (free + buffer + cache) "MemAvailable:" info
+ used = total - available
+ usedratio = used / total
+ freeratio = free / total
+ availableratio = available / total
+ return [usedratio, freeratio, availableratio, total, free, buffer, cache, available, used]
+
+totalMem :: IO Float
+totalMem = fmap ((*1024) . (!!1)) parseMEM
+
+usedMem :: IO Float
+usedMem = fmap ((*1024) . (!!6)) parseMEM
+
+formatMem :: MemOpts -> [Float] -> Monitor [String]
+formatMem opts (r:fr:ar:xs) =
+ do let f = showDigits 0
+ mon i x = [showPercentBar (100 * x) x, showVerticalBar (100 * x) x, showIconPattern i x]
+ sequence $ mon (usedIconPattern opts) r
+ ++ mon (freeIconPattern opts) fr
+ ++ mon (availableIconPattern opts) ar
+ ++ map showPercentWithColors [r, fr, ar]
+ ++ map (showWithColors f) xs
+formatMem _ _ = replicate 10 `fmap` getConfigValue naString
+
+runMem :: [String] -> Monitor String
+runMem argv =
+ do m <- io parseMEM
+ opts <- io $ parseOpts argv
+ l <- formatMem opts m
+ parseTemplate l
diff --git a/src/Xmobar/Plugins/Monitors/Mpris.hs b/src/Xmobar/Plugins/Monitors/Mpris.hs
new file mode 100644
index 0000000..3556649
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Mpris.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Mpris
+-- Copyright : (c) Artem Tarasov
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Artem Tarasov <lomereiter@gmail.com>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- MPRIS song info
+--
+----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Mpris ( mprisConfig, runMPRIS1, runMPRIS2 ) where
+
+-- TODO: listen to signals
+
+import Xmobar.Plugins.Monitors.Common
+
+import Text.Printf (printf)
+
+import DBus
+import qualified DBus.Client as DC
+
+import Control.Arrow ((***))
+import Data.Maybe ( fromJust )
+import Data.Int ( Int32, Int64 )
+import System.IO.Unsafe (unsafePerformIO)
+
+import Control.Exception (try)
+
+class MprisVersion a where
+ getMethodCall :: a -> String -> MethodCall
+ getMetadataReply :: a -> DC.Client -> String -> IO [Variant]
+ getMetadataReply mv c p = fmap methodReturnBody (DC.call_ c $ getMethodCall mv p)
+ fieldsList :: a -> [String]
+
+data MprisVersion1 = MprisVersion1
+instance MprisVersion MprisVersion1 where
+ getMethodCall MprisVersion1 p = (methodCall objectPath interfaceName memberName)
+ { methodCallDestination = Just busName
+ }
+ where
+ busName = busName_ $ "org.mpris." ++ p
+ objectPath = objectPath_ "/Player"
+ interfaceName = interfaceName_ "org.freedesktop.MediaPlayer"
+ memberName = memberName_ "GetMetadata"
+
+ fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title"
+ , "tracknumber" ]
+
+data MprisVersion2 = MprisVersion2
+instance MprisVersion MprisVersion2 where
+ getMethodCall MprisVersion2 p = (methodCall objectPath interfaceName memberName)
+ { methodCallDestination = Just busName
+ , methodCallBody = arguments
+ }
+ where
+ busName = busName_ $ "org.mpris.MediaPlayer2." ++ p
+ objectPath = objectPath_ "/org/mpris/MediaPlayer2"
+ interfaceName = interfaceName_ "org.freedesktop.DBus.Properties"
+ memberName = memberName_ "Get"
+ arguments = map (toVariant::String -> Variant)
+ ["org.mpris.MediaPlayer2.Player", "Metadata"]
+
+ fieldsList MprisVersion2 = [ "xesam:album", "xesam:artist", "mpris:artUrl"
+ , "mpris:length", "xesam:title",
+ "xesam:trackNumber", "xesam:composer",
+ "xesam:genre"
+ ]
+
+mprisConfig :: IO MConfig
+mprisConfig = mkMConfig "<artist> - <title>"
+ [ "album", "artist", "arturl", "length"
+ , "title", "tracknumber" , "composer", "genre"
+ ]
+
+{-# NOINLINE dbusClient #-}
+dbusClient :: DC.Client
+dbusClient = unsafePerformIO DC.connectSession
+
+runMPRIS :: (MprisVersion a) => a -> String -> [String] -> Monitor String
+runMPRIS version playerName _ = do
+ metadata <- io $ getMetadata version dbusClient playerName
+ if [] == metadata then
+ getConfigValue naString
+ else mapM showWithPadding (makeList version metadata) >>= parseTemplate
+
+runMPRIS1 :: String -> [String] -> Monitor String
+runMPRIS1 = runMPRIS MprisVersion1
+
+runMPRIS2 :: String -> [String] -> Monitor String
+runMPRIS2 = runMPRIS MprisVersion2
+
+---------------------------------------------------------------------------
+
+fromVar :: (IsVariant a) => Variant -> a
+fromVar = fromJust . fromVariant
+
+unpackMetadata :: [Variant] -> [(String, Variant)]
+unpackMetadata [] = []
+unpackMetadata xs =
+ (map (fromVar *** fromVar) . unpack . head) xs where
+ unpack v = case variantType v of
+ TypeDictionary _ _ -> dictionaryItems $ fromVar v
+ TypeVariant -> unpack $ fromVar v
+ TypeStructure _ ->
+ let x = structureItems (fromVar v) in
+ if null x then [] else unpack (head x)
+ _ -> []
+
+getMetadata :: (MprisVersion a) => a -> DC.Client -> String -> IO [(String, Variant)]
+getMetadata version client player = do
+ reply <- try (getMetadataReply version client player) ::
+ IO (Either DC.ClientError [Variant])
+ return $ case reply of
+ Right metadata -> unpackMetadata metadata;
+ Left _ -> []
+
+makeList :: (MprisVersion a) => a -> [(String, Variant)] -> [String]
+makeList version md = map getStr (fieldsList version) where
+ formatTime n = (if hh == 0 then printf "%02d:%02d"
+ else printf "%d:%02d:%02d" hh) mm ss
+ where hh = (n `div` 60) `div` 60
+ mm = (n `div` 60) `mod` 60
+ ss = n `mod` 60
+ getStr str = case lookup str md of
+ Nothing -> ""
+ Just v -> case variantType v of
+ TypeString -> fromVar v
+ TypeInt32 -> let num = fromVar v in
+ case str of
+ "mtime" -> formatTime (num `div` 1000)
+ "tracknumber" -> printf "%02d" num
+ "mpris:length" -> formatTime (num `div` 1000000)
+ "xesam:trackNumber" -> printf "%02d" num
+ _ -> (show::Int32 -> String) num
+ TypeInt64 -> let num = fromVar v in
+ case str of
+ "mpris:length" -> formatTime (num `div` 1000000)
+ _ -> (show::Int64 -> String) num
+ TypeArray TypeString ->
+ let x = arrayItems (fromVar v) in
+ if null x then "" else fromVar (head x)
+ _ -> ""
diff --git a/src/Xmobar/Plugins/Monitors/MultiCpu.hs b/src/Xmobar/Plugins/Monitors/MultiCpu.hs
new file mode 100644
index 0000000..3db3b5f
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/MultiCpu.hs
@@ -0,0 +1,128 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.MultiCpu
+-- Copyright : (c) Jose A Ortega Ruiz
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A Ortega <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A multi-cpu monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.MultiCpu (startMultiCpu) where
+
+import Xmobar.Plugins.Monitors.Common
+import Control.Applicative ((<$>))
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.List (isPrefixOf, transpose, unfoldr)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import System.Console.GetOpt
+
+data MultiCpuOpts = MultiCpuOpts
+ { loadIconPatterns :: [IconPattern]
+ , loadIconPattern :: Maybe IconPattern
+ , fallbackIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: MultiCpuOpts
+defaultOpts = MultiCpuOpts
+ { loadIconPatterns = []
+ , loadIconPattern = Nothing
+ , fallbackIconPattern = Nothing
+ }
+
+options :: [OptDescr (MultiCpuOpts -> MultiCpuOpts)]
+options =
+ [ Option "" ["load-icon-pattern"] (ReqArg (\x o ->
+ o { loadIconPattern = Just $ parseIconPattern x }) "") ""
+ , Option "" ["load-icon-patterns"] (ReqArg (\x o ->
+ o { loadIconPatterns = parseIconPattern x : loadIconPatterns o }) "") ""
+ , Option "" ["fallback-icon-pattern"] (ReqArg (\x o ->
+ o { fallbackIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+parseOpts :: [String] -> IO MultiCpuOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+variables :: [String]
+variables = ["bar", "vbar","ipat","total","user","nice","system","idle"]
+vNum :: Int
+vNum = length variables
+
+multiCpuConfig :: IO MConfig
+multiCpuConfig =
+ mkMConfig "Cpu: <total>%" $
+ ["auto" ++ k | k <- variables] ++
+ [ k ++ n | n <- "" : map show [0 :: Int ..]
+ , k <- variables]
+
+type CpuDataRef = IORef [[Int]]
+
+cpuData :: IO [[Int]]
+cpuData = parse `fmap` B.readFile "/proc/stat"
+ where parse = map parseList . cpuLists
+ cpuLists = takeWhile isCpu . map B.words . B.lines
+ isCpu (w:_) = "cpu" `isPrefixOf` B.unpack w
+ isCpu _ = False
+ parseList = map (parseInt . B.unpack) . tail
+
+parseCpuData :: CpuDataRef -> IO [[Float]]
+parseCpuData cref =
+ do as <- readIORef cref
+ bs <- cpuData
+ writeIORef cref bs
+ let p0 = zipWith percent bs as
+ return p0
+
+percent :: [Int] -> [Int] -> [Float]
+percent b a = if tot > 0 then map (/ tot) $ take 4 dif else [0, 0, 0, 0]
+ where dif = map fromIntegral $ zipWith (-) b a
+ tot = sum dif
+
+formatMultiCpus :: MultiCpuOpts -> [[Float]] -> Monitor [String]
+formatMultiCpus _ [] = return []
+formatMultiCpus opts xs = concat <$> mapM (\(i, x) -> formatCpu opts i x) (zip [0..] xs)
+
+formatCpu :: MultiCpuOpts -> Int -> [Float] -> Monitor [String]
+formatCpu opts i xs
+ | length xs < 4 = showPercentsWithColors $ replicate vNum 0.0
+ | otherwise = let t = sum $ take 3 xs
+ in do b <- showPercentBar (100 * t) t
+ h <- showVerticalBar (100 * t) t
+ d <- showIconPattern tryString t
+ ps <- showPercentsWithColors (t:xs)
+ return (b:h:d:ps)
+ where tryString
+ | i == 0 = loadIconPattern opts
+ | i <= length (loadIconPatterns opts) = Just $ loadIconPatterns opts !! (i - 1)
+ | otherwise = fallbackIconPattern opts
+
+splitEvery :: Int -> [a] -> [[a]]
+splitEvery n = unfoldr (\x -> if null x then Nothing else Just $ splitAt n x)
+
+groupData :: [String] -> [[String]]
+groupData = transpose . tail . splitEvery vNum
+
+formatAutoCpus :: [String] -> Monitor [String]
+formatAutoCpus [] = return $ replicate vNum ""
+formatAutoCpus xs = return $ map unwords (groupData xs)
+
+runMultiCpu :: CpuDataRef -> [String] -> Monitor String
+runMultiCpu cref argv =
+ do c <- io $ parseCpuData cref
+ opts <- io $ parseOpts argv
+ l <- formatMultiCpus opts c
+ a <- formatAutoCpus l
+ parseTemplate $ a ++ l
+
+startMultiCpu :: [String] -> Int -> (String -> IO ()) -> IO ()
+startMultiCpu a r cb = do
+ cref <- newIORef [[]]
+ _ <- parseCpuData cref
+ runM a multiCpuConfig (runMultiCpu cref) r cb
diff --git a/src/Xmobar/Plugins/Monitors/Net.hs b/src/Xmobar/Plugins/Monitors/Net.hs
new file mode 100644
index 0000000..81a5f6b
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Net.hs
@@ -0,0 +1,218 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Net
+-- Copyright : (c) 2011, 2012, 2013, 2014, 2017 Jose Antonio Ortega Ruiz
+-- (c) 2007-2010 Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A net device monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Net (
+ startNet
+ , startDynNet
+ ) where
+
+import Xmobar.Plugins.Monitors.Common
+
+import Data.Word (Word64)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
+import Control.Monad (forM, filterM)
+import System.Directory (getDirectoryContents, doesFileExist)
+import System.FilePath ((</>))
+import System.Console.GetOpt
+import System.IO.Error (catchIOError)
+
+import qualified Data.ByteString.Lazy.Char8 as B
+
+data NetOpts = NetOpts
+ { rxIconPattern :: Maybe IconPattern
+ , txIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: NetOpts
+defaultOpts = NetOpts
+ { rxIconPattern = Nothing
+ , txIconPattern = Nothing
+ }
+
+options :: [OptDescr (NetOpts -> NetOpts)]
+options =
+ [ Option "" ["rx-icon-pattern"] (ReqArg (\x o ->
+ o { rxIconPattern = Just $ parseIconPattern x }) "") ""
+ , Option "" ["tx-icon-pattern"] (ReqArg (\x o ->
+ o { txIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+parseOpts :: [String] -> IO NetOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+data UnitPerSec = Bs | KBs | MBs | GBs deriving (Eq,Enum,Ord)
+data NetValue = NetValue Float UnitPerSec deriving (Eq,Show)
+
+instance Show UnitPerSec where
+ show Bs = "B/s"
+ show KBs = "KB/s"
+ show MBs = "MB/s"
+ show GBs = "GB/s"
+
+data NetDev num
+ = NA
+ | NI String
+ | ND String num num deriving (Eq,Show,Read)
+
+type NetDevRawTotal = NetDev Word64
+type NetDevRate = NetDev Float
+
+type NetDevRef = IORef (NetDevRawTotal, UTCTime)
+
+-- The more information available, the better.
+-- Note that names don't matter. Therefore, if only the names differ,
+-- a compare evaluates to EQ while (==) evaluates to False.
+instance Ord num => Ord (NetDev num) where
+ compare NA NA = EQ
+ compare NA _ = LT
+ compare _ NA = GT
+ compare (NI _) (NI _) = EQ
+ compare (NI _) ND {} = LT
+ compare ND {} (NI _) = GT
+ compare (ND _ x1 y1) (ND _ x2 y2) =
+ if downcmp /= EQ
+ then downcmp
+ else y1 `compare` y2
+ where downcmp = x1 `compare` x2
+
+netConfig :: IO MConfig
+netConfig = mkMConfig
+ "<dev>: <rx>KB|<tx>KB" -- template
+ ["dev", "rx", "tx", "rxbar", "rxvbar", "rxipat", "txbar", "txvbar", "txipat"] -- available replacements
+
+operstateDir :: String -> FilePath
+operstateDir d = "/sys/class/net" </> d </> "operstate"
+
+existingDevs :: IO [String]
+existingDevs = getDirectoryContents "/sys/class/net" >>= filterM isDev
+ where isDev d | d `elem` excludes = return False
+ | otherwise = doesFileExist (operstateDir d)
+ excludes = [".", "..", "lo"]
+
+isUp :: String -> IO Bool
+isUp d = flip catchIOError (const $ return False) $ do
+ operstate <- B.readFile (operstateDir d)
+ return $! (B.unpack . head . B.lines) operstate `elem` ["up", "unknown"]
+
+readNetDev :: [String] -> IO NetDevRawTotal
+readNetDev (d:x:y:_) = do
+ up <- isUp d
+ return (if up then ND d (r x) (r y) else NI d)
+ where r s | s == "" = 0
+ | otherwise = read s
+
+readNetDev _ = return NA
+
+netParser :: B.ByteString -> IO [NetDevRawTotal]
+netParser = mapM (readNetDev . splitDevLine) . readDevLines
+ where readDevLines = drop 2 . B.lines
+ splitDevLine = selectCols . wordsBy (`elem` " :") . B.unpack
+ selectCols cols = map (cols!!) [0,1,9]
+ wordsBy f s = case dropWhile f s of
+ [] -> []
+ s' -> w : wordsBy f s'' where (w, s'') = break f s'
+
+findNetDev :: String -> IO NetDevRawTotal
+findNetDev dev = do
+ nds <- B.readFile "/proc/net/dev" >>= netParser
+ case filter isDev nds of
+ x:_ -> return x
+ _ -> return NA
+ where isDev (ND d _ _) = d == dev
+ isDev (NI d) = d == dev
+ isDev NA = False
+
+formatNet :: Maybe IconPattern -> Float -> Monitor (String, String, String, String)
+formatNet mipat d = do
+ s <- getConfigValue useSuffix
+ dd <- getConfigValue decDigits
+ let str True v = showDigits dd d' ++ show u
+ where (NetValue d' u) = byteNetVal v
+ str False v = showDigits dd $ v / 1024
+ b <- showLogBar 0.9 d
+ vb <- showLogVBar 0.9 d
+ ipat <- showLogIconPattern mipat 0.9 d
+ x <- showWithColors (str s) d
+ return (x, b, vb, ipat)
+
+printNet :: NetOpts -> NetDevRate -> Monitor String
+printNet opts nd =
+ case nd of
+ ND d r t -> do
+ (rx, rb, rvb, ripat) <- formatNet (rxIconPattern opts) r
+ (tx, tb, tvb, tipat) <- formatNet (txIconPattern opts) t
+ parseTemplate [d,rx,tx,rb,rvb,ripat,tb,tvb,tipat]
+ NI _ -> return ""
+ NA -> getConfigValue naString
+
+parseNet :: NetDevRef -> String -> IO NetDevRate
+parseNet nref nd = do
+ (n0, t0) <- readIORef nref
+ n1 <- findNetDev nd
+ t1 <- getCurrentTime
+ writeIORef nref (n1, t1)
+ let scx = realToFrac (diffUTCTime t1 t0)
+ scx' = if scx > 0 then scx else 1
+ rate da db = takeDigits 2 $ fromIntegral (db - da) / scx'
+ diffRate (ND d ra ta) (ND _ rb tb) = ND d (rate ra rb) (rate ta tb)
+ diffRate (NI d) _ = NI d
+ diffRate _ (NI d) = NI d
+ diffRate _ _ = NA
+ return $ diffRate n0 n1
+
+runNet :: NetDevRef -> String -> [String] -> Monitor String
+runNet nref i argv = do
+ dev <- io $ parseNet nref i
+ opts <- io $ parseOpts argv
+ printNet opts dev
+
+parseNets :: [(NetDevRef, String)] -> IO [NetDevRate]
+parseNets = mapM $ uncurry parseNet
+
+runNets :: [(NetDevRef, String)] -> [String] -> Monitor String
+runNets refs argv = do
+ dev <- io $ parseActive refs
+ opts <- io $ parseOpts argv
+ printNet opts dev
+ where parseActive refs' = fmap selectActive (parseNets refs')
+ selectActive = maximum
+
+startNet :: String -> [String] -> Int -> (String -> IO ()) -> IO ()
+startNet i a r cb = do
+ t0 <- getCurrentTime
+ nref <- newIORef (NA, t0)
+ _ <- parseNet nref i
+ runM a netConfig (runNet nref i) r cb
+
+startDynNet :: [String] -> Int -> (String -> IO ()) -> IO ()
+startDynNet a r cb = do
+ devs <- existingDevs
+ refs <- forM devs $ \d -> do
+ t <- getCurrentTime
+ nref <- newIORef (NA, t)
+ _ <- parseNet nref d
+ return (nref, d)
+ runM a netConfig (runNets refs) r cb
+
+byteNetVal :: Float -> NetValue
+byteNetVal v
+ | v < 1024**1 = NetValue v Bs
+ | v < 1024**2 = NetValue (v/1024**1) KBs
+ | v < 1024**3 = NetValue (v/1024**2) MBs
+ | otherwise = NetValue (v/1024**3) GBs
diff --git a/src/Xmobar/Plugins/Monitors/Swap.hs b/src/Xmobar/Plugins/Monitors/Swap.hs
new file mode 100644
index 0000000..fcaab84
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Swap.hs
@@ -0,0 +1,56 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Swap
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A swap usage monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Swap where
+
+import Xmobar.Plugins.Monitors.Common
+
+import qualified Data.ByteString.Lazy.Char8 as B
+
+swapConfig :: IO MConfig
+swapConfig = mkMConfig
+ "Swap: <usedratio>%" -- template
+ ["usedratio", "total", "used", "free"] -- available replacements
+
+fileMEM :: IO B.ByteString
+fileMEM = B.readFile "/proc/meminfo"
+
+parseMEM :: IO [Float]
+parseMEM =
+ do file <- fileMEM
+ let li i l
+ | l /= [] = head l !! i
+ | otherwise = B.empty
+ fs s l
+ | null l = False
+ | otherwise = head l == B.pack s
+ get_data s = flip (/) 1024 . read . B.unpack . li 1 . filter (fs s)
+ st = map B.words . B.lines $ file
+ tot = get_data "SwapTotal:" st
+ free = get_data "SwapFree:" st
+ return [(tot - free) / tot, tot, tot - free, free]
+
+formatSwap :: [Float] -> Monitor [String]
+formatSwap (r:xs) = do
+ d <- getConfigValue decDigits
+ other <- mapM (showWithColors (showDigits d)) xs
+ ratio <- showPercentWithColors r
+ return $ ratio:other
+formatSwap _ = return $ replicate 4 "N/A"
+
+runSwap :: [String] -> Monitor String
+runSwap _ =
+ do m <- io parseMEM
+ l <- formatSwap m
+ parseTemplate l
diff --git a/src/Xmobar/Plugins/Monitors/Thermal.hs b/src/Xmobar/Plugins/Monitors/Thermal.hs
new file mode 100644
index 0000000..320ae17
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Thermal.hs
@@ -0,0 +1,39 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Thermal
+-- Copyright : (c) Juraj Hercek
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A thermal monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Thermal where
+
+import qualified Data.ByteString.Lazy.Char8 as B
+import Xmobar.Plugins.Monitors.Common
+import System.Posix.Files (fileExist)
+
+-- | Default thermal configuration.
+thermalConfig :: IO MConfig
+thermalConfig = mkMConfig
+ "Thm: <temp>C" -- template
+ ["temp"] -- available replacements
+
+-- | Retrieves thermal information. Argument is name of thermal directory in
+-- \/proc\/acpi\/thermal_zone. Returns the monitor string parsed according to
+-- template (either default or user specified).
+runThermal :: [String] -> Monitor String
+runThermal args = do
+ let zone = head args
+ file = "/proc/acpi/thermal_zone/" ++ zone ++ "/temperature"
+ exists <- io $ fileExist file
+ if exists
+ then do number <- io $ fmap ((read :: String -> Int) . stringParser (1, 0)) (B.readFile file)
+ thermal <- showWithColors show number
+ parseTemplate [ thermal ]
+ else return $ "Thermal (" ++ zone ++ "): N/A"
diff --git a/src/Xmobar/Plugins/Monitors/ThermalZone.hs b/src/Xmobar/Plugins/Monitors/ThermalZone.hs
new file mode 100644
index 0000000..bc46b59
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/ThermalZone.hs
@@ -0,0 +1,49 @@
+------------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.ThermalZone
+-- Copyright : (c) 2011, 2013 Jose Antonio Ortega Ruiz
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : jao@gnu.org
+-- Stability : unstable
+-- Portability : portable
+-- Created : Fri Feb 25, 2011 03:18
+--
+--
+-- A thermal zone plugin based on the sysfs linux interface.
+-- See http://kernel.org/doc/Documentation/thermal/sysfs-api.txt
+--
+------------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.ThermalZone (thermalZoneConfig, runThermalZone) where
+
+import Xmobar.Plugins.Monitors.Common
+
+import System.Posix.Files (fileExist)
+import Control.Exception (IOException, catch)
+import qualified Data.ByteString.Char8 as B
+
+-- | Default thermal configuration.
+thermalZoneConfig :: IO MConfig
+thermalZoneConfig = mkMConfig "<temp>C" ["temp"]
+
+-- | Retrieves thermal information. Argument is name of thermal
+-- directory in \/sys\/clas\/thermal. Returns the monitor string
+-- parsed according to template (either default or user specified).
+runThermalZone :: [String] -> Monitor String
+runThermalZone args = do
+ let zone = head args
+ file = "/sys/class/thermal/thermal_zone" ++ zone ++ "/temp"
+ handleIOError :: IOException -> IO (Maybe B.ByteString)
+ handleIOError _ = return Nothing
+ parse = return . (read :: String -> Int) . B.unpack
+ exists <- io $ fileExist file
+ if exists
+ then do contents <- io $ catch (fmap Just $ B.readFile file) handleIOError
+ case contents of
+ Just d -> do
+ mdegrees <- parse d
+ temp <- showWithColors show (mdegrees `quot` 1000)
+ parseTemplate [ temp ]
+ Nothing -> getConfigValue naString
+ else getConfigValue naString
diff --git a/src/Xmobar/Plugins/Monitors/Top.hs b/src/Xmobar/Plugins/Monitors/Top.hs
new file mode 100644
index 0000000..d6df249
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Top.hs
@@ -0,0 +1,195 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Top
+-- Copyright : (c) 2010, 2011, 2012, 2013, 2014, 2018 Jose A Ortega Ruiz
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Process activity and memory consumption monitors
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE BangPatterns #-}
+
+module Xmobar.Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where
+
+import Xmobar.Plugins.Monitors.Common
+
+import Control.Exception (SomeException, handle)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.List (sortBy, foldl')
+import Data.Ord (comparing)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
+import System.Directory (getDirectoryContents)
+import System.FilePath ((</>))
+import System.IO (IOMode(ReadMode), hGetLine, withFile)
+import System.Posix.Unistd (SysVar(ClockTick), getSysVar)
+
+import Foreign.C.Types
+
+maxEntries :: Int
+maxEntries = 10
+
+intStrs :: [String]
+intStrs = map show [1..maxEntries]
+
+topMemConfig :: IO MConfig
+topMemConfig = mkMConfig "<both1>"
+ [ k ++ n | n <- intStrs , k <- ["name", "mem", "both"]]
+
+topConfig :: IO MConfig
+topConfig = mkMConfig "<both1>"
+ ("no" : [ k ++ n | n <- intStrs
+ , k <- [ "name", "cpu", "both"
+ , "mname", "mem", "mboth"]])
+
+foreign import ccall "unistd.h getpagesize"
+ c_getpagesize :: CInt
+
+pageSize :: Float
+pageSize = fromIntegral c_getpagesize / 1024
+
+processes :: IO [FilePath]
+processes = fmap (filter isPid) (getDirectoryContents "/proc")
+ where isPid = (`elem` ['0'..'9']) . head
+
+statWords :: [String] -> [String]
+statWords line@(x:pn:ppn:xs) =
+ if last pn == ')' then line else statWords (x:(pn ++ " " ++ ppn):xs)
+statWords _ = replicate 52 "0"
+
+getProcessData :: FilePath -> IO [String]
+getProcessData pidf =
+ handle ign $ withFile ("/proc" </> pidf </> "stat") ReadMode readWords
+ where readWords = fmap (statWords . words) . hGetLine
+ ign = const (return []) :: SomeException -> IO [String]
+
+memPages :: [String] -> String
+memPages fs = fs!!23
+
+ppid :: [String] -> String
+ppid fs = fs!!3
+
+skip :: [String] -> Bool
+skip fs = length fs < 24 || memPages fs == "0" || ppid fs == "0"
+
+handleProcesses :: ([String] -> a) -> IO [a]
+handleProcesses f =
+ fmap (foldl' (\a p -> if skip p then a else f p : a) [])
+ (processes >>= mapM getProcessData)
+
+showInfo :: String -> String -> Float -> Monitor [String]
+showInfo nm sms mms = do
+ mnw <- getConfigValue maxWidth
+ mxw <- getConfigValue minWidth
+ let lsms = length sms
+ nmw = mnw - lsms - 1
+ nmx = mxw - lsms - 1
+ rnm = if nmw > 0 then padString nmw nmx " " True "" nm else nm
+ mstr <- showWithColors' sms mms
+ both <- showWithColors' (rnm ++ " " ++ sms) mms
+ return [nm, mstr, both]
+
+processName :: [String] -> String
+processName = drop 1 . init . (!!1)
+
+sortTop :: [(String, Float)] -> [(String, Float)]
+sortTop = sortBy (flip (comparing snd))
+
+type MemInfo = (String, Float)
+
+meminfo :: [String] -> MemInfo
+meminfo fs = (processName fs, pageSize * parseFloat (fs!!23))
+
+meminfos :: IO [MemInfo]
+meminfos = handleProcesses meminfo
+
+showMemInfo :: Float -> MemInfo -> Monitor [String]
+showMemInfo scale (nm, rss) =
+ showInfo nm (showWithUnits 3 1 rss) (100 * rss / sc)
+ where sc = if scale > 0 then scale else 100
+
+showMemInfos :: [MemInfo] -> Monitor [[String]]
+showMemInfos ms = mapM (showMemInfo tm) ms
+ where tm = sum (map snd ms)
+
+runTopMem :: [String] -> Monitor String
+runTopMem _ = do
+ mis <- io meminfos
+ pstr <- showMemInfos (sortTop mis)
+ parseTemplate $ concat pstr
+
+type Pid = Int
+type TimeInfo = (String, Float)
+type TimeEntry = (Pid, TimeInfo)
+type Times = [TimeEntry]
+type TimesRef = IORef (Times, UTCTime)
+
+timeMemEntry :: [String] -> (TimeEntry, MemInfo)
+timeMemEntry fs = ((p, (n, t)), (n, r))
+ where p = parseInt (head fs)
+ n = processName fs
+ t = parseFloat (fs!!13) + parseFloat (fs!!14)
+ (_, r) = meminfo fs
+
+timeMemEntries :: IO [(TimeEntry, MemInfo)]
+timeMemEntries = handleProcesses timeMemEntry
+
+timeMemInfos :: IO (Times, [MemInfo], Int)
+timeMemInfos = fmap res timeMemEntries
+ where res x = (sortBy (comparing fst) $ map fst x, map snd x, length x)
+
+combine :: Times -> Times -> Times
+combine _ [] = []
+combine [] ts = ts
+combine l@((p0, (n0, t0)):ls) r@((p1, (n1, t1)):rs)
+ | p0 == p1 && n0 == n1 = (p0, (n0, t1 - t0)) : combine ls rs
+ | p0 <= p1 = combine ls r
+ | otherwise = (p1, (n1, t1)) : combine l rs
+
+take' :: Int -> [a] -> [a]
+take' m l = let !r = tk m l in length l `seq` r
+ where tk 0 _ = []
+ tk _ [] = []
+ tk n (x:xs) = let !r = tk (n - 1) xs in x : r
+
+topProcesses :: TimesRef -> Float -> IO (Int, [TimeInfo], [MemInfo])
+topProcesses tref scale = do
+ (t0, c0) <- readIORef tref
+ (t1, mis, len) <- timeMemInfos
+ c1 <- getCurrentTime
+ let scx = realToFrac (diffUTCTime c1 c0) * scale
+ !scx' = if scx > 0 then scx else scale
+ nts = map (\(_, (nm, t)) -> (nm, min 100 (t / scx'))) (combine t0 t1)
+ !t1' = take' (length t1) t1
+ !nts' = take' maxEntries (sortTop nts)
+ !mis' = take' maxEntries (sortTop mis)
+ writeIORef tref (t1', c1)
+ return (len, nts', mis')
+
+showTimeInfo :: TimeInfo -> Monitor [String]
+showTimeInfo (n, t) =
+ getConfigValue decDigits >>= \d -> showInfo n (showDigits d t) t
+
+showTimeInfos :: [TimeInfo] -> Monitor [[String]]
+showTimeInfos = mapM showTimeInfo
+
+runTop :: TimesRef -> Float -> [String] -> Monitor String
+runTop tref scale _ = do
+ (no, ps, ms) <- io $ topProcesses tref scale
+ pstr <- showTimeInfos ps
+ mstr <- showMemInfos ms
+ parseTemplate $ show no : concat (zipWith (++) pstr mstr) ++ repeat "N/A"
+
+startTop :: [String] -> Int -> (String -> IO ()) -> IO ()
+startTop a r cb = do
+ cr <- getSysVar ClockTick
+ c <- getCurrentTime
+ tref <- newIORef ([], c)
+ let scale = fromIntegral cr / 100
+ _ <- topProcesses tref scale
+ runM a topConfig (runTop tref scale) r cb
diff --git a/src/Xmobar/Plugins/Monitors/UVMeter.hs b/src/Xmobar/Plugins/Monitors/UVMeter.hs
new file mode 100644
index 0000000..079177f
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/UVMeter.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.UVMeter
+-- Copyright : (c) Róman Joost
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Róman Joost
+-- Stability : unstable
+-- Portability : unportable
+--
+-- An australian uv monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.UVMeter where
+
+import Xmobar.Plugins.Monitors.Common
+
+import qualified Control.Exception as CE
+import Network.HTTP.Conduit
+ (parseRequest, newManager, tlsManagerSettings, httpLbs,
+ responseBody)
+import Data.ByteString.Lazy.Char8 as B
+import Text.Read (readMaybe)
+import Text.Parsec
+import Text.Parsec.String
+import Control.Monad (void)
+
+
+uvConfig :: IO MConfig
+uvConfig = mkMConfig
+ "<station>" -- template
+ ["station" -- available replacements
+ ]
+
+newtype UvInfo = UV { index :: String }
+ deriving (Show)
+
+uvURL :: String
+uvURL = "https://uvdata.arpansa.gov.au/xml/uvvalues.xml"
+
+getData :: IO String
+getData =
+ CE.catch (do request <- parseRequest uvURL
+ manager <- newManager tlsManagerSettings
+ res <- httpLbs request manager
+ return $ B.unpack $ responseBody res)
+ errHandler
+ where errHandler
+ :: CE.SomeException -> IO String
+ errHandler _ = return "<Could not retrieve data>"
+
+textToXMLDocument :: String -> Either ParseError [XML]
+textToXMLDocument = parse document ""
+
+formatUVRating :: Maybe Float -> Monitor String
+formatUVRating Nothing = getConfigValue naString
+formatUVRating (Just x) = do
+ uv <- showWithColors show x
+ parseTemplate [uv]
+
+getUVRating :: String -> [XML] -> Maybe Float
+getUVRating locID (Element "stations" _ y:_) = getUVRating locID y
+getUVRating locID (Element "location" [Attribute attr] ys:xs)
+ | locID == snd attr = getUVRating locID ys
+ | otherwise = getUVRating locID xs
+getUVRating _ (Element "index" [] [Body rate]:_) = readMaybe rate
+getUVRating locID (_:xs) = getUVRating locID xs
+getUVRating _ [] = Nothing
+
+
+runUVMeter :: [String] -> Monitor String
+runUVMeter [] = return "N.A."
+runUVMeter (s:_) = do
+ resp <- io getData
+ case textToXMLDocument resp of
+ Right doc -> formatUVRating (getUVRating s doc)
+ Left _ -> getConfigValue naString
+
+-- | XML Parsing code comes here.
+-- This is a very simple XML parser to just deal with the uvvalues.xml
+-- provided by ARPANSA. If you work on a new plugin which needs an XML
+-- parser perhaps consider using a real XML parser and refactor this
+-- plug-in to us it as well.
+--
+-- Note: This parser can not deal with short tags.
+--
+-- Kudos to: Charlie Harvey for his article about writing an XML Parser
+-- with Parsec.
+--
+
+type AttrName = String
+type AttrValue = String
+
+newtype Attribute = Attribute (AttrName, AttrValue)
+ deriving (Show)
+
+data XML = Element String [Attribute] [XML]
+ | Decl String
+ | Body String
+ deriving (Show)
+
+-- | parse the document
+--
+document :: Parser [XML]
+document = do
+ spaces
+ y <- try xmlDecl <|> tag
+ spaces
+ x <- many tag
+ spaces
+ return (y : x)
+
+-- | parse any tags
+--
+tag :: Parser XML
+tag = do
+ char '<'
+ spaces
+ name <- many (letter <|> digit)
+ spaces
+ attr <- many attribute
+ spaces
+ string ">"
+ eBody <- many elementBody
+ endTag name
+ spaces
+ return (Element name attr eBody)
+
+xmlDecl :: Parser XML
+xmlDecl = do
+ void $ manyTill anyToken (string "<?xml") -- ignore the byte order mark
+ decl <- many (noneOf "?>")
+ string "?>"
+ return (Decl decl)
+
+elementBody :: Parser XML
+elementBody = spaces *> try tag <|> text
+
+endTag :: String -> Parser String
+endTag str = string "</" *> string str <* char '>'
+
+text :: Parser XML
+text = Body <$> many1 (noneOf "><")
+
+attribute :: Parser Attribute
+attribute = do
+ name <- many (noneOf "= />")
+ spaces
+ char '='
+ spaces
+ char '"'
+ value <- many (noneOf "\"")
+ char '"'
+ spaces
+ return (Attribute (name, value))
diff --git a/src/Xmobar/Plugins/Monitors/Uptime.hs b/src/Xmobar/Plugins/Monitors/Uptime.hs
new file mode 100644
index 0000000..235fc85
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Uptime.hs
@@ -0,0 +1,50 @@
+------------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Uptime
+-- Copyright : (c) 2010 Jose Antonio Ortega Ruiz
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : jao@gnu.org
+-- Stability : unstable
+-- Portability : unportable
+-- Created: Sun Dec 12, 2010 20:26
+--
+--
+-- Uptime
+--
+------------------------------------------------------------------------------
+
+
+module Xmobar.Plugins.Monitors.Uptime (uptimeConfig, runUptime) where
+
+import Xmobar.Plugins.Monitors.Common
+
+import qualified Data.ByteString.Lazy.Char8 as B
+
+uptimeConfig :: IO MConfig
+uptimeConfig = mkMConfig "Up <days>d <hours>h <minutes>m"
+ ["days", "hours", "minutes", "seconds"]
+
+readUptime :: IO Float
+readUptime =
+ fmap (read . B.unpack . head . B.words) (B.readFile "/proc/uptime")
+
+secsPerDay :: Integer
+secsPerDay = 24 * 3600
+
+uptime :: Monitor [String]
+uptime = do
+ t <- io readUptime
+ u <- getConfigValue useSuffix
+ let tsecs = floor t
+ secs = tsecs `mod` secsPerDay
+ days = tsecs `quot` secsPerDay
+ hours = secs `quot` 3600
+ mins = (secs `mod` 3600) `div` 60
+ ss = secs `mod` 60
+ str x s = if u then show x ++ s else show x
+ mapM (`showWithColors'` days)
+ [str days "d", str hours "h", str mins "m", str ss "s"]
+
+runUptime :: [String] -> Monitor String
+runUptime _ = uptime >>= parseTemplate
diff --git a/src/Xmobar/Plugins/Monitors/Volume.hs b/src/Xmobar/Plugins/Monitors/Volume.hs
new file mode 100644
index 0000000..1d3281c
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Volume.hs
@@ -0,0 +1,196 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Volume
+-- Copyright : (c) 2011, 2013, 2015, 2018 Thomas Tuegel
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A monitor for ALSA soundcards
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Volume
+ ( runVolume
+ , runVolumeWith
+ , volumeConfig
+ , options
+ , defaultOpts
+ , VolumeOpts
+ ) where
+
+import Control.Applicative ((<$>))
+import Control.Monad ( liftM2, liftM3, mplus )
+import Data.Traversable (sequenceA)
+import Xmobar.Plugins.Monitors.Common
+import Sound.ALSA.Mixer
+import qualified Sound.ALSA.Exception as AE
+import System.Console.GetOpt
+
+volumeConfig :: IO MConfig
+volumeConfig = mkMConfig "Vol: <volume>% <status>"
+ ["volume", "volumebar", "volumevbar", "dB","status", "volumeipat"]
+
+
+data VolumeOpts = VolumeOpts
+ { onString :: String
+ , offString :: String
+ , onColor :: Maybe String
+ , offColor :: Maybe String
+ , highDbThresh :: Float
+ , lowDbThresh :: Float
+ , volumeIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: VolumeOpts
+defaultOpts = VolumeOpts
+ { onString = "[on] "
+ , offString = "[off]"
+ , onColor = Just "green"
+ , offColor = Just "red"
+ , highDbThresh = -5.0
+ , lowDbThresh = -30.0
+ , volumeIconPattern = Nothing
+ }
+
+options :: [OptDescr (VolumeOpts -> VolumeOpts)]
+options =
+ [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") ""
+ , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") ""
+ , Option "" ["lowd"] (ReqArg (\x o -> o { lowDbThresh = read x }) "") ""
+ , Option "" ["highd"] (ReqArg (\x o -> o { highDbThresh = read x }) "") ""
+ , Option "C" ["onc"] (ReqArg (\x o -> o { onColor = Just x }) "") ""
+ , Option "c" ["offc"] (ReqArg (\x o -> o { offColor = Just x }) "") ""
+ , Option "" ["volume-icon-pattern"] (ReqArg (\x o ->
+ o { volumeIconPattern = Just $ parseIconPattern x }) "") ""
+ ]
+
+parseOpts :: [String] -> IO VolumeOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+percent :: Integer -> Integer -> Integer -> Float
+percent v' lo' hi' = (v - lo) / (hi - lo)
+ where v = fromIntegral v'
+ lo = fromIntegral lo'
+ hi = fromIntegral hi'
+
+formatVol :: Integer -> Integer -> Integer -> Monitor String
+formatVol lo hi v =
+ showPercentWithColors $ percent v lo hi
+
+formatVolBar :: Integer -> Integer -> Integer -> Monitor String
+formatVolBar lo hi v =
+ showPercentBar (100 * x) x where x = percent v lo hi
+
+formatVolVBar :: Integer -> Integer -> Integer -> Monitor String
+formatVolVBar lo hi v =
+ showVerticalBar (100 * x) x where x = percent v lo hi
+
+formatVolDStr :: Maybe IconPattern -> Integer -> Integer -> Integer -> Monitor String
+formatVolDStr ipat lo hi v =
+ showIconPattern ipat $ percent v lo hi
+
+switchHelper :: VolumeOpts
+ -> (VolumeOpts -> Maybe String)
+ -> (VolumeOpts -> String)
+ -> Monitor String
+switchHelper opts cHelp strHelp = return $
+ colorHelper (cHelp opts)
+ ++ strHelp opts
+ ++ maybe "" (const "</fc>") (cHelp opts)
+
+formatSwitch :: VolumeOpts -> Bool -> Monitor String
+formatSwitch opts True = switchHelper opts onColor onString
+formatSwitch opts False = switchHelper opts offColor offString
+
+colorHelper :: Maybe String -> String
+colorHelper = maybe "" (\c -> "<fc=" ++ c ++ ">")
+
+formatDb :: VolumeOpts -> Integer -> Monitor String
+formatDb opts dbi = do
+ h <- getConfigValue highColor
+ m <- getConfigValue normalColor
+ l <- getConfigValue lowColor
+ d <- getConfigValue decDigits
+ let db = fromIntegral dbi / 100.0
+ digits = showDigits d db
+ startColor | db >= highDbThresh opts = colorHelper h
+ | db < lowDbThresh opts = colorHelper l
+ | otherwise = colorHelper m
+ stopColor | null startColor = ""
+ | otherwise = "</fc>"
+ return $ startColor ++ digits ++ stopColor
+
+runVolume :: String -> String -> [String] -> Monitor String
+runVolume mixerName controlName argv = do
+ opts <- io $ parseOpts argv
+ runVolumeWith opts mixerName controlName
+
+runVolumeWith :: VolumeOpts -> String -> String -> Monitor String
+runVolumeWith opts mixerName controlName = do
+ (lo, hi, val, db, sw) <- io readMixer
+ p <- liftMonitor $ liftM3 formatVol lo hi val
+ b <- liftMonitor $ liftM3 formatVolBar lo hi val
+ v <- liftMonitor $ liftM3 formatVolVBar lo hi val
+ d <- getFormatDB opts db
+ s <- getFormatSwitch opts sw
+ ipat <- liftMonitor $ liftM3 (formatVolDStr $ volumeIconPattern opts) lo hi val
+ parseTemplate [p, b, v, d, s, ipat]
+
+ where
+
+ readMixer =
+ AE.catch (withMixer mixerName $ \mixer -> do
+ control <- getControlByName mixer controlName
+ (lo, hi) <- liftMaybe $ getRange <$> volumeControl control
+ val <- getVal $ volumeControl control
+ db <- getDB $ volumeControl control
+ sw <- getSw $ switchControl control
+ return (lo, hi, val, db, sw))
+ (const $ return (Nothing, Nothing, Nothing, Nothing, Nothing))
+
+ volumeControl :: Maybe Control -> Maybe Volume
+ volumeControl c = (playback . volume =<< c)
+ `mplus` (capture . volume =<< c)
+ `mplus` (common . volume =<< c)
+
+ switchControl :: Maybe Control -> Maybe Switch
+ switchControl c = (playback . switch =<< c)
+ `mplus` (capture . switch =<< c)
+ `mplus` (common . switch =<< c)
+
+ liftMaybe :: Maybe (IO (a,b)) -> IO (Maybe a, Maybe b)
+ liftMaybe = fmap (liftM2 (,) (fmap fst) (fmap snd)) . sequenceA
+
+ liftMonitor :: Maybe (Monitor String) -> Monitor String
+ liftMonitor Nothing = unavailable
+ liftMonitor (Just m) = m
+
+ channel v r = AE.catch (getChannel FrontLeft v) (const $ return $ Just r)
+
+ getDB :: Maybe Volume -> IO (Maybe Integer)
+ getDB Nothing = return Nothing
+ getDB (Just v) = channel (dB v) 0
+
+ getVal :: Maybe Volume -> IO (Maybe Integer)
+ getVal Nothing = return Nothing
+ getVal (Just v) = channel (value v) 0
+
+ getSw :: Maybe Switch -> IO (Maybe Bool)
+ getSw Nothing = return Nothing
+ getSw (Just s) = channel s False
+
+ getFormatDB :: VolumeOpts -> Maybe Integer -> Monitor String
+ getFormatDB _ Nothing = unavailable
+ getFormatDB opts' (Just d) = formatDb opts' d
+
+ getFormatSwitch :: VolumeOpts -> Maybe Bool -> Monitor String
+ getFormatSwitch _ Nothing = unavailable
+ getFormatSwitch opts' (Just sw) = formatSwitch opts' sw
+
+ unavailable = getConfigValue naString
diff --git a/src/Xmobar/Plugins/Monitors/Weather.hs b/src/Xmobar/Plugins/Monitors/Weather.hs
new file mode 100644
index 0000000..cb5bf07
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Weather.hs
@@ -0,0 +1,255 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Weather
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A weather monitor for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Weather where
+
+import Xmobar.Plugins.Monitors.Common
+
+import qualified Control.Exception as CE
+
+#ifdef HTTP_CONDUIT
+import Network.HTTP.Conduit
+import Network.HTTP.Types.Status
+import Network.HTTP.Types.Method
+import qualified Data.ByteString.Lazy.Char8 as B
+#else
+import Network.HTTP
+#endif
+
+import Text.ParserCombinators.Parsec
+
+weatherConfig :: IO MConfig
+weatherConfig = mkMConfig
+ "<station>: <tempC>C, rh <rh>% (<hour>)" -- template
+ ["station" -- available replacements
+ , "stationState"
+ , "year"
+ , "month"
+ , "day"
+ , "hour"
+ , "windCardinal"
+ , "windAzimuth"
+ , "windMph"
+ , "windKnots"
+ , "windKmh"
+ , "windMs"
+ , "visibility"
+ , "skyCondition"
+ , "tempC"
+ , "tempF"
+ , "dewPointC"
+ , "dewPointF"
+ , "rh"
+ , "pressure"
+ ]
+
+data WindInfo =
+ WindInfo {
+ windCardinal :: String -- cardinal direction
+ , windAzimuth :: String -- azimuth direction
+ , windMph :: String -- speed (MPH)
+ , windKnots :: String -- speed (knot)
+ , windKmh :: String -- speed (km/h)
+ , windMs :: String -- speed (m/s)
+ } deriving (Show)
+
+data WeatherInfo =
+ WI { stationPlace :: String
+ , stationState :: String
+ , year :: String
+ , month :: String
+ , day :: String
+ , hour :: String
+ , windInfo :: WindInfo
+ , visibility :: String
+ , skyCondition :: String
+ , tempC :: Int
+ , tempF :: Int
+ , dewPointC :: Int
+ , dewPointF :: Int
+ , humidity :: Int
+ , pressure :: Int
+ } deriving (Show)
+
+pTime :: Parser (String, String, String, String)
+pTime = do y <- getNumbersAsString
+ char '.'
+ m <- getNumbersAsString
+ char '.'
+ d <- getNumbersAsString
+ char ' '
+ (h:hh:mi:mimi) <- getNumbersAsString
+ char ' '
+ return (y, m, d ,h:hh:":"++mi:mimi)
+
+noWind :: WindInfo
+noWind = WindInfo "μ" "μ" "0" "0" "0" "0"
+
+pWind :: Parser WindInfo
+pWind =
+ let tospace = manyTill anyChar (char ' ')
+ toKmh knots = knots $* 1.852
+ toMs knots = knots $* 0.514
+ ($*) :: String -> Double -> String
+ op1 $* op2 = show (round ((read op1::Double) * op2)::Integer)
+
+ -- Occasionally there is no wind and a METAR report gives simply, "Wind: Calm:0"
+ wind0 = do manyTill skipRestOfLine (string "Wind: Calm:0")
+ return noWind
+ windVar = do manyTill skipRestOfLine (string "Wind: Variable at ")
+ mph <- tospace
+ string "MPH ("
+ knot <- tospace
+ manyTill anyChar newline
+ return $ WindInfo "μ" "μ" mph knot (toKmh knot) (toMs knot)
+ wind = do manyTill skipRestOfLine (string "Wind: from the ")
+ cardinal <- tospace
+ char '('
+ azimuth <- tospace
+ string "degrees) at "
+ mph <- tospace
+ string "MPH ("
+ knot <- tospace
+ manyTill anyChar newline
+ return $ WindInfo cardinal azimuth mph knot (toKmh knot) (toMs knot)
+ in try wind0 <|> try windVar <|> try wind <|> return noWind
+
+pTemp :: Parser (Int, Int)
+pTemp = do let num = digit <|> char '-' <|> char '.'
+ f <- manyTill num $ char ' '
+ manyTill anyChar $ char '('
+ c <- manyTill num $ char ' '
+ skipRestOfLine
+ return (floor (read c :: Double), floor (read f :: Double))
+
+pRh :: Parser Int
+pRh = do s <- manyTill digit (char '%' <|> char '.')
+ return $ read s
+
+pPressure :: Parser Int
+pPressure = do manyTill anyChar $ char '('
+ s <- manyTill digit $ char ' '
+ skipRestOfLine
+ return $ read s
+
+{-
+ example of 'http://weather.noaa.gov/pub/data/observations/metar/decoded/VTUD.TXT':
+ Station name not available
+ Aug 11, 2013 - 10:00 AM EDT / 2013.08.11 1400 UTC
+ Wind: from the N (350 degrees) at 1 MPH (1 KT):0
+ Visibility: 4 mile(s):0
+ Sky conditions: mostly clear
+ Temperature: 77 F (25 C)
+ Dew Point: 73 F (23 C)
+ Relative Humidity: 88%
+ Pressure (altimeter): 29.77 in. Hg (1008 hPa)
+ ob: VTUD 111400Z 35001KT 8000 FEW030 25/23 Q1008 A2977 INFO R RWY30
+ cycle: 14
+-}
+parseData :: Parser [WeatherInfo]
+parseData =
+ do (st, ss) <- try (string "Station name not available" >> return ("??", "??")) <|>
+ (do st <- getAllBut ","
+ space
+ ss <- getAllBut "("
+ return (st, ss)
+ )
+ skipRestOfLine >> getAllBut "/"
+ (y,m,d,h) <- pTime
+ w <- pWind
+ v <- getAfterString "Visibility: "
+ sk <- getAfterString "Sky conditions: "
+ skipTillString "Temperature: "
+ (tC,tF) <- pTemp
+ skipTillString "Dew Point: "
+ (dC, dF) <- pTemp
+ skipTillString "Relative Humidity: "
+ rh <- pRh
+ skipTillString "Pressure (altimeter): "
+ p <- pPressure
+ manyTill skipRestOfLine eof
+ return [WI st ss y m d h w v sk tC tF dC dF rh p]
+
+defUrl :: String
+-- "http://weather.noaa.gov/pub/data/observations/metar/decoded/"
+defUrl = "http://tgftp.nws.noaa.gov/data/observations/metar/decoded/"
+
+stationUrl :: String -> String
+stationUrl station = defUrl ++ station ++ ".TXT"
+
+getData :: String -> IO String
+#ifdef HTTP_CONDUIT
+getData station = CE.catch (do
+ manager <- newManager tlsManagerSettings
+ request <- parseUrl $ stationUrl station
+ res <- httpLbs request manager
+ return $ B.unpack $ responseBody res
+ ) errHandler
+ where errHandler :: CE.SomeException -> IO String
+ errHandler _ = return "<Could not retrieve data>"
+#else
+getData station = do
+ let request = getRequest (stationUrl station)
+ CE.catch (simpleHTTP request >>= getResponseBody) errHandler
+ where errHandler :: CE.IOException -> IO String
+ errHandler _ = return "<Could not retrieve data>"
+#endif
+
+formatWeather :: [WeatherInfo] -> Monitor String
+formatWeather [WI st ss y m d h (WindInfo wc wa wm wk wkh wms) v sk tC tF dC dF r p] =
+ do cel <- showWithColors show tC
+ far <- showWithColors show tF
+ parseTemplate [st, ss, y, m, d, h, wc, wa, wm, wk, wkh, wms, v, sk, cel, far, show dC, show dF, show r , show p ]
+formatWeather _ = getConfigValue naString
+
+runWeather :: [String] -> Monitor String
+runWeather str =
+ do d <- io $ getData $ head str
+ i <- io $ runP parseData d
+ formatWeather i
+
+weatherReady :: [String] -> Monitor Bool
+#ifdef HTTP_CONDUIT
+weatherReady str = do
+ initRequest <- parseUrl $ stationUrl $ head str
+ let request = initRequest{method = methodHead}
+ io $ CE.catch ( do
+ manager <- newManager tlsManagerSettings
+ res <- httpLbs request manager
+ return $ checkResult $responseStatus res ) errHandler
+ where errHandler :: CE.SomeException -> IO Bool
+ errHandler _ = return False
+ checkResult status
+ | statusIsServerError status = False
+ | statusIsClientError status = False
+ | otherwise = True
+#else
+weatherReady str = do
+ let station = head str
+ request = headRequest (stationUrl station)
+ io $ CE.catch (simpleHTTP request >>= checkResult) errHandler
+ where errHandler :: CE.IOException -> IO Bool
+ errHandler _ = return False
+ checkResult result =
+ case result of
+ Left _ -> return False
+ Right response ->
+ case rspCode response of
+ -- Permission or network errors are failures; anything
+ -- else is recoverable.
+ (4, _, _) -> return False
+ (5, _, _) -> return False
+ (_, _, _) -> return True
+#endif
diff --git a/src/Xmobar/Plugins/Monitors/Wireless.hs b/src/Xmobar/Plugins/Monitors/Wireless.hs
new file mode 100644
index 0000000..545f6bc
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Wireless.hs
@@ -0,0 +1,70 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Wireless
+-- Copyright : (c) Jose Antonio Ortega Ruiz
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose Antonio Ortega Ruiz
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A monitor reporting ESSID and link quality for wireless interfaces
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.Monitors.Wireless (wirelessConfig, runWireless) where
+
+import System.Console.GetOpt
+
+import Xmobar.Plugins.Monitors.Common
+import Network.IWlib
+
+newtype WirelessOpts = WirelessOpts
+ { qualityIconPattern :: Maybe IconPattern
+ }
+
+defaultOpts :: WirelessOpts
+defaultOpts = WirelessOpts
+ { qualityIconPattern = Nothing
+ }
+
+options :: [OptDescr (WirelessOpts -> WirelessOpts)]
+options =
+ [ Option "" ["quality-icon-pattern"] (ReqArg (\d opts ->
+ opts { qualityIconPattern = Just $ parseIconPattern d }) "") ""
+ ]
+
+parseOpts :: [String] -> IO WirelessOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+wirelessConfig :: IO MConfig
+wirelessConfig =
+ mkMConfig "<essid> <quality>"
+ ["essid", "quality", "qualitybar", "qualityvbar", "qualityipat"]
+
+runWireless :: String -> [String] -> Monitor String
+runWireless iface args = do
+ opts <- io $ parseOpts args
+ iface' <- if "" == iface then io findInterface else return iface
+ wi <- io $ getWirelessInfo iface'
+ na <- getConfigValue naString
+ let essid = wiEssid wi
+ qlty = fromIntegral $ wiQuality wi
+ e = if essid == "" then na else essid
+ ep <- showWithPadding e
+ q <- if qlty >= 0
+ then showPercentWithColors (qlty / 100)
+ else showWithPadding ""
+ qb <- showPercentBar qlty (qlty / 100)
+ qvb <- showVerticalBar qlty (qlty / 100)
+ qipat <- showIconPattern (qualityIconPattern opts) (qlty / 100)
+ parseTemplate [ep, q, qb, qvb, qipat]
+
+findInterface :: IO String
+findInterface = do
+ c <- readFile "/proc/net/wireless"
+ let nds = lines c
+ return $ if length nds > 2 then takeWhile (/= 'c') (nds!!2) else []
diff --git a/src/Xmobar/Plugins/PipeReader.hs b/src/Xmobar/Plugins/PipeReader.hs
new file mode 100644
index 0000000..f18b9cb
--- /dev/null
+++ b/src/Xmobar/Plugins/PipeReader.hs
@@ -0,0 +1,48 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.PipeReader
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin for reading from named pipes
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.PipeReader(PipeReader(..)) where
+
+import System.IO
+import Xmobar.Utils(hGetLineSafe)
+import Xmobar.Run.Commands(Exec(..))
+import Xmobar.System.Environment(expandEnv)
+import System.Posix.Files
+import Control.Concurrent(threadDelay)
+import Control.Exception
+import Control.Monad(forever, unless)
+import Control.Applicative ((<$>))
+
+data PipeReader = PipeReader String String
+ deriving (Read, Show)
+
+instance Exec PipeReader where
+ alias (PipeReader _ a) = a
+ start (PipeReader p _) cb = do
+ (def, pipe) <- split ':' <$> expandEnv p
+ unless (null def) (cb def)
+ checkPipe pipe
+ h <- openFile pipe ReadWriteMode
+ forever (hGetLineSafe h >>= cb)
+ where
+ split c xs | c `elem` xs = let (pre, post) = span (c /=) xs
+ in (pre, dropWhile (c ==) post)
+ | otherwise = ([], xs)
+
+checkPipe :: FilePath -> IO ()
+checkPipe file =
+ handle (\(SomeException _) -> waitForPipe) $ do
+ status <- getFileStatus file
+ unless (isNamedPipe status) waitForPipe
+ where waitForPipe = threadDelay 1000000 >> checkPipe file
diff --git a/src/Xmobar/Plugins/StdinReader.hs b/src/Xmobar/Plugins/StdinReader.hs
new file mode 100644
index 0000000..bed7f5c
--- /dev/null
+++ b/src/Xmobar/Plugins/StdinReader.hs
@@ -0,0 +1,45 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.StdinReader
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin for reading from `stdin`.
+--
+-- Exports:
+-- - `StdinReader` to safely display stdin content (striping actions).
+-- - `UnsafeStdinReader` to display stdin content as-is.
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.StdinReader (StdinReader(..)) where
+
+import Prelude
+import System.Posix.Process
+import System.Exit
+import System.IO
+import Control.Exception (SomeException(..), handle)
+import Xmobar.Actions (stripActions)
+import Xmobar.Utils (hGetLineSafe)
+import Xmobar.Run.Commands
+
+data StdinReader = StdinReader | UnsafeStdinReader
+ deriving (Read, Show)
+
+instance Exec StdinReader where
+ start stdinReader cb = do
+ s <- handle (\(SomeException e) -> do hPrint stderr e; return "")
+ (hGetLineSafe stdin)
+ cb $ escape stdinReader s
+ eof <- isEOF
+ if eof
+ then exitImmediately ExitSuccess
+ else start stdinReader cb
+
+escape :: StdinReader -> String -> String
+escape StdinReader = stripActions
+escape UnsafeStdinReader = id
diff --git a/src/Xmobar/Plugins/XMonadLog.hs b/src/Xmobar/Plugins/XMonadLog.hs
new file mode 100644
index 0000000..a4f17bb
--- /dev/null
+++ b/src/Xmobar/Plugins/XMonadLog.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.StdinReader
+-- Copyright : (c) Spencer Janssen
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A plugin to display information from _XMONAD_LOG, specified at
+-- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs
+--
+-----------------------------------------------------------------------------
+
+module Xmobar.Plugins.XMonadLog (XMonadLog(..)) where
+
+import Control.Monad
+import Graphics.X11
+import Graphics.X11.Xlib.Extras
+import Xmobar.Run.Commands
+#ifdef UTF8
+#undef UTF8
+import Codec.Binary.UTF8.String as UTF8
+#define UTF8
+#endif
+import Foreign.C (CChar)
+import Xmobar.Utils (nextEvent')
+import Xmobar.Actions (stripActions)
+
+data XMonadLog = XMonadLog
+ | UnsafeXMonadLog
+ | XPropertyLog String
+ | UnsafeXPropertyLog String
+ | NamedXPropertyLog String String
+ | UnsafeNamedXPropertyLog String String
+ deriving (Read, Show)
+
+instance Exec XMonadLog where
+ alias XMonadLog = "XMonadLog"
+ alias UnsafeXMonadLog = "UnsafeXMonadLog"
+ alias (XPropertyLog atom) = atom
+ alias (NamedXPropertyLog _ name) = name
+ alias (UnsafeXPropertyLog atom) = atom
+ alias (UnsafeNamedXPropertyLog _ name) = name
+
+ start x cb = do
+ let atom = case x of
+ XMonadLog -> "_XMONAD_LOG"
+ UnsafeXMonadLog -> "_XMONAD_LOG"
+ XPropertyLog a -> a
+ UnsafeXPropertyLog a -> a
+ NamedXPropertyLog a _ -> a
+ UnsafeNamedXPropertyLog a _ -> a
+ sanitize = case x of
+ UnsafeXMonadLog -> id
+ UnsafeXPropertyLog _ -> id
+ UnsafeNamedXPropertyLog _ _ -> id
+ _ -> stripActions
+
+ d <- openDisplay ""
+ xlog <- internAtom d atom False
+
+ root <- rootWindow d (defaultScreen d)
+ selectInput d root propertyChangeMask
+
+ let update = do
+ mwp <- getWindowProperty8 d xlog root
+ maybe (return ()) (cb . sanitize . decodeCChar) mwp
+
+ update
+
+ allocaXEvent $ \ep -> forever $ do
+ nextEvent' d ep
+ e <- getEvent ep
+ case e of
+ PropertyEvent { ev_atom = a } | a == xlog -> update
+ _ -> return ()
+
+ return ()
+
+decodeCChar :: [CChar] -> String
+#ifdef UTF8
+#undef UTF8
+decodeCChar = UTF8.decode . map fromIntegral
+#define UTF8
+#else
+decodeCChar = map (toEnum . fromIntegral)
+#endif