diff options
Diffstat (limited to 'src/Xmobar/Plugins')
39 files changed, 0 insertions, 5108 deletions
diff --git a/src/Xmobar/Plugins/BufferedPipeReader.hs b/src/Xmobar/Plugins/BufferedPipeReader.hs deleted file mode 100644 index d4d30a1..0000000 --- a/src/Xmobar/Plugins/BufferedPipeReader.hs +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.BufferedPipeReader --- Copyright : (c) Jochen Keil --- License : BSD-style (see LICENSE) --- --- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> --- Stability : unstable --- Portability : unportable --- --- A plugin for reading (temporarily) from named pipes with reset --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.BufferedPipeReader where - -import Control.Monad(forM_, when, void) -import Control.Concurrent -import Control.Concurrent.STM -import System.IO -import System.IO.Unsafe(unsafePerformIO) - -import Xmobar.Environment -import Xmobar.Plugins -import Xmobar.Signal - -data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] - deriving (Read, Show) - -{-# NOINLINE signal #-} -signal :: MVar SignalType -signal = unsafePerformIO newEmptyMVar - -instance Exec BufferedPipeReader where - alias ( BufferedPipeReader a _ ) = a - - trigger br@( BufferedPipeReader _ _ ) sh = - takeMVar signal >>= sh . Just >> trigger br sh - - start ( BufferedPipeReader _ ps ) cb = do - - (chan, str, rst) <- initV - forM_ ps $ \p -> forkIO $ reader p chan - writer chan str rst - - where - initV :: IO ( TChan (Int, Bool, String), TVar (Maybe String), TVar Bool ) - initV = atomically $ do - tc <- newTChan - ts <- newTVar Nothing - tb <- newTVar False - return (tc, ts, tb) - - reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () - reader p@(to, tg, fp) tc = do - fp' <- expandEnv fp - openFile fp' ReadWriteMode >>= hGetLineSafe >>= \dt -> - atomically $ writeTChan tc (to, tg, dt) - reader p tc - - writer :: TChan (Int, Bool, String) - -> TVar (Maybe String) -> TVar Bool -> IO () - writer tc ts otb = do - (to, tg, dt, ntb) <- update - cb dt - when tg $ putMVar signal $ Reveal 0 - when (to /= 0) $ sfork $ reset to tg ts ntb - writer tc ts ntb - - where - sfork :: IO () -> IO () - sfork f = void (forkIO f) - - update :: IO (Int, Bool, String, TVar Bool) - update = atomically $ do - (to, tg, dt) <- readTChan tc - when (to == 0) $ writeTVar ts $ Just dt - writeTVar otb False - tb <- newTVar True - return (to, tg, dt, tb) - - reset :: Int -> Bool -> TVar (Maybe String) -> TVar Bool -> IO () - reset to tg ts tb = do - threadDelay ( to * 100 * 1000 ) - readTVarIO tb >>= \b -> when b $ do - when tg $ putMVar signal $ Hide 0 - readTVarIO ts >>= maybe (return ()) cb diff --git a/src/Xmobar/Plugins/CommandReader.hs b/src/Xmobar/Plugins/CommandReader.hs deleted file mode 100644 index 80b6299..0000000 --- a/src/Xmobar/Plugins/CommandReader.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.CommandReader --- Copyright : (c) John Goerzen --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from external commands --- note: stderr is lost here --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.CommandReader where - -import System.IO -import Xmobar.Plugins -import System.Process(runInteractiveCommand, getProcessExitCode) - -data CommandReader = CommandReader String String - deriving (Read, Show) - -instance Exec CommandReader where - alias (CommandReader _ a) = a - start (CommandReader p _) cb = do - (hstdin, hstdout, hstderr, ph) <- runInteractiveCommand p - hClose hstdin - hClose hstderr - hSetBinaryMode hstdout False - hSetBuffering hstdout LineBuffering - forever ph (hGetLineSafe hstdout >>= cb) - where forever ph a = - do a - ec <- getProcessExitCode ph - case ec of - Nothing -> forever ph a - Just _ -> cb "EXITED" diff --git a/src/Xmobar/Plugins/Date.hs b/src/Xmobar/Plugins/Date.hs deleted file mode 100644 index fdc6a56..0000000 --- a/src/Xmobar/Plugins/Date.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Date --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A date plugin for Xmobar --- --- Usage example: in template put --- --- > Run Date "%a %b %_d %Y <fc=#ee9a00> %H:%M:%S</fc>" "Mydate" 10 --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Date (Date(..)) where - -import Xmobar.Plugins - -#if ! MIN_VERSION_time(1,5,0) -import System.Locale -#endif -import Data.Time - -data Date = Date String String Int - deriving (Read, Show) - -instance Exec Date where - alias (Date _ a _) = a - run (Date f _ _) = date f - rate (Date _ _ r) = r - -date :: String -> IO String -date format = fmap (formatTime defaultTimeLocale format) getZonedTime diff --git a/src/Xmobar/Plugins/DateZone.hs b/src/Xmobar/Plugins/DateZone.hs deleted file mode 100644 index 753f530..0000000 --- a/src/Xmobar/Plugins/DateZone.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DoAndIfThenElse #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.DateZone --- Copyright : (c) Martin Perner --- License : BSD-style (see LICENSE) --- --- Maintainer : Martin Perner <martin@perner.cc> --- Stability : unstable --- Portability : unportable --- --- A date plugin with localization and location support for Xmobar --- --- Based on Plugins.Date --- --- Usage example: in template put --- --- > Run DateZone "%a %H:%M:%S" "de_DE.UTF-8" "UTC" "utcDate" 10 --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.DateZone (DateZone(..)) where - -import Xmobar.Plugins - - -#ifdef DATEZONE -import Control.Concurrent.STM - -import System.IO.Unsafe - -import Xmobar.Localize -import Data.Time.Format -import Data.Time.LocalTime -import Data.Time.LocalTime.TimeZone.Olson -import Data.Time.LocalTime.TimeZone.Series - -#if ! MIN_VERSION_time(1,5,0) -import System.Locale (TimeLocale) -#endif -#else -import System.IO -import Xmobar.Plugins.Date -#endif - - - -data DateZone = DateZone String String String String Int - deriving (Read, Show) - -instance Exec DateZone where - alias (DateZone _ _ _ a _) = a -#ifndef DATEZONE - start (DateZone f _ _ a r) cb = do - hPutStrLn stderr $ "Warning: DateZone plugin needs -fwith_datezone."++ - " Using Date plugin instead." - start (Date f a r) cb -#else - start (DateZone f l z _ r) cb = do - lock <- atomically $ takeTMVar localeLock - setupTimeLocale l - locale <- getTimeLocale - atomically $ putTMVar localeLock lock - if z /= "" then do - timeZone <- getTimeZoneSeriesFromOlsonFile ("/usr/share/zoneinfo/" ++ z) - go (dateZone f locale timeZone) - else - go (date f locale) - - where go func = func >>= cb >> tenthSeconds r >> go func - -{-# NOINLINE localeLock #-} --- ensures that only one plugin instance sets the locale -localeLock :: TMVar Bool -localeLock = unsafePerformIO (newTMVarIO False) - -date :: String -> TimeLocale -> IO String -date format loc = getZonedTime >>= return . formatTime loc format - -dateZone :: String -> TimeLocale -> TimeZoneSeries -> IO String -dateZone format loc timeZone = getZonedTime >>= return . formatTime loc format . utcToLocalTime' timeZone . zonedTimeToUTC --- zonedTime <- getZonedTime --- return $ formatTime loc format $ utcToLocalTime' timeZone $ zonedTimeToUTC zonedTime -#endif diff --git a/src/Xmobar/Plugins/EWMH.hs b/src/Xmobar/Plugins/EWMH.hs deleted file mode 100644 index 363ec90..0000000 --- a/src/Xmobar/Plugins/EWMH.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# LANGUAGE CPP, NamedFieldPuns, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.EWMH --- Copyright : (c) Spencer Janssen --- License : BSD-style (see LICENSE) --- --- Maintainer : Spencer Janssen <spencerjanssen@gmail.com> --- Stability : unstable --- Portability : unportable --- --- An experimental plugin to display EWMH pager information --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.EWMH (EWMH(..)) where - -import Control.Applicative (Applicative(..)) -import Control.Monad.State -import Control.Monad.Reader -import Graphics.X11 hiding (Modifier, Color) -import Graphics.X11.Xlib.Extras -import Xmobar.Plugins -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar, CLong) -import Xmobar.XUtil (nextEvent') - -import Data.List (intersperse, intercalate) - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - - -data EWMH = EWMH | EWMHFMT Component deriving (Read, Show) - -instance Exec EWMH where - alias EWMH = "EWMH" - - start ew cb = allocaXEvent $ \ep -> execM $ do - d <- asks display - r <- asks root - - liftIO xSetErrorHandler - - liftIO $ selectInput d r propertyChangeMask - handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers - mapM_ ((=<< asks root) . snd) handlers' - - forever $ do - liftIO . cb . fmtOf ew =<< get - liftIO $ nextEvent' d ep - e <- liftIO $ getEvent ep - case e of - PropertyEvent { ev_atom = a, ev_window = w } -> - case lookup a handlers' of - Just f -> f w - _ -> return () - _ -> return () - - return () - -defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty] - , Layout - , Color "#00ee00" "" :$ Short 120 :$ WindowName] - -fmtOf EWMH = flip fmt defaultPP -fmtOf (EWMHFMT f) = flip fmt f - -sep :: [a] -> [[a]] -> [a] -sep x xs = intercalate x $ filter (not . null) xs - -fmt :: EwmhState -> Component -> String -fmt e (Text s) = s -fmt e (l :+ r) = fmt e l ++ fmt e r -fmt e (m :$ r) = modifier m $ fmt e r -fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs -fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e) -fmt e Layout = layout e -fmt e (Workspaces opts) = sep " " - [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as] - | (n, as) <- attrs] - where - stats i = [ (Current, i == currentDesktop e) - , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e) - -- TODO for visible , (Visibl - ] - attrs :: [(String, [WsType])] - attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)] - nonEmptys = Set.unions . map desktops . Map.elems $ clients e - -modifier :: Modifier -> String -> String -modifier Hide = const "" -modifier (Color fg bg) = \x -> concat ["<fc=", fg, if null bg then "" else "," ++ bg - , ">", x, "</fc>"] -modifier (Short n) = take n -modifier (Wrap l r) = \x -> l ++ x ++ r - -data Component = Text String - | Component :+ Component - | Modifier :$ Component - | Sep Component [Component] - | WindowName - | Layout - | Workspaces [WsOpt] - deriving (Read, Show) - -infixr 0 :$ -infixr 5 :+ - -data Modifier = Hide - | Color String String - | Short Int - | Wrap String String - deriving (Read, Show) - -data WsOpt = Modifier :% WsType - | WSep Component - deriving (Read, Show) -infixr 0 :% - -data WsType = Current | Empty | Visible - deriving (Read, Show, Eq) - -data EwmhConf = C { root :: Window - , display :: Display } - -data EwmhState = S { currentDesktop :: CLong - , activeWindow :: Window - , desktopNames :: [String] - , layout :: String - , clients :: Map Window Client } - deriving Show - -data Client = Cl { windowName :: String - , desktops :: Set CLong } - deriving Show - -getAtom :: String -> M Atom -getAtom s = do - d <- asks display - liftIO $ internAtom d s False - -windowProperty32 :: String -> Window -> M (Maybe [CLong]) -windowProperty32 s w = do - C {display} <- ask - a <- getAtom s - liftIO $ getWindowProperty32 display a w - -windowProperty8 :: String -> Window -> M (Maybe [CChar]) -windowProperty8 s w = do - C {display} <- ask - a <- getAtom s - liftIO $ getWindowProperty8 display a w - -initialState :: EwmhState -initialState = S 0 0 [] [] Map.empty - -initialClient :: Client -initialClient = Cl "" Set.empty - -handlers, clientHandlers :: [(String, Updater)] -handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop) - , ("_NET_DESKTOP_NAMES", updateDesktopNames ) - , ("_NET_ACTIVE_WINDOW", updateActiveWindow) - , ("_NET_CLIENT_LIST", updateClientList) - ] ++ clientHandlers - -clientHandlers = [ ("_NET_WM_NAME", updateName) - , ("_NET_WM_DESKTOP", updateDesktop) ] - -newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a) - deriving (Monad, Functor, Applicative, MonadIO, MonadReader EwmhConf, MonadState EwmhState) - -execM :: M a -> IO a -execM (M m) = do - d <- openDisplay "" - r <- rootWindow d (defaultScreen d) - let conf = C r d - evalStateT (runReaderT m (C r d)) initialState - -type Updater = Window -> M () - -updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater -updateCurrentDesktop _ = do - C {root} <- ask - mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root - case mwp of - Just [x] -> modify (\s -> s { currentDesktop = x }) - _ -> return () - -updateActiveWindow _ = do - C {root} <- ask - mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root - case mwp of - Just [x] -> modify (\s -> s { activeWindow = fromIntegral x }) - _ -> return () - -updateDesktopNames _ = do - C {root} <- ask - mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root - case mwp of - Just xs -> modify (\s -> s { desktopNames = parse xs }) - _ -> return () - where - dropNull ('\0':xs) = xs - dropNull xs = xs - - split [] = [] - split xs = case span (/= '\0') xs of - (x, ys) -> x : split (dropNull ys) - parse = split . decodeCChar - -updateClientList _ = do - C {root} <- ask - mwp <- windowProperty32 "_NET_CLIENT_LIST" root - case mwp of - Just xs -> do - cl <- gets clients - let cl' = Map.fromList $ map ((, initialClient) . fromIntegral) xs - dels = Map.difference cl cl' - new = Map.difference cl' cl - modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'}) - mapM_ (unmanage . fst) (Map.toList dels) - mapM_ (listen . fst) (Map.toList cl') - mapM_ (update . fst) (Map.toList new) - _ -> return () - where - unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0 - listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask - update w = mapM_ (($ w) . snd) clientHandlers - -modifyClient :: Window -> (Client -> Client) -> M () -modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s }) - where - f' Nothing = Just $ f initialClient - f' (Just x) = Just $ f x - -updateName w = do - mwp <- windowProperty8 "_NET_WM_NAME" w - case mwp of - Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs }) - _ -> return () - -updateDesktop w = do - mwp <- windowProperty32 "_NET_WM_DESKTOP" w - case mwp of - Just x -> modifyClient w (\c -> c { desktops = Set.fromList x }) - _ -> return () - -decodeCChar :: [CChar] -> String -#ifdef UTF8 -#undef UTF8 -decodeCChar = UTF8.decode . map fromIntegral -#define UTF8 -#else -decodeCChar = map (toEnum . fromIntegral) -#endif diff --git a/src/Xmobar/Plugins/Kbd.hsc b/src/Xmobar/Plugins/Kbd.hsc deleted file mode 100644 index 372386e..0000000 --- a/src/Xmobar/Plugins/Kbd.hsc +++ /dev/null @@ -1,404 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Kbd --- Copyright : (c) Martin Perner --- License : BSD-style (see LICENSE) --- --- Maintainer : Martin Perner <martin@perner.cc> --- Stability : unstable --- Portability : unportable --- --- A keyboard layout indicator for Xmobar --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Kbd where - -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras -import Foreign -import Foreign.C.Types -import Foreign.C.String -import Xmobar.Plugins -import Control.Monad (forever) -import Xmobar.XUtil (nextEvent') -import Data.List (isPrefixOf, findIndex) -import Data.Maybe (fromJust) - -#include <X11/XKBlib.h> -#include <X11/extensions/XKB.h> -#include <X11/extensions/XKBstr.h> - --- --- Definition for XkbStaceRec and getKbdLayout taken from --- XMonad.Layout.XKBLayout --- -data XkbStateRec = XkbStateRec { - group :: CUChar, - locked_group :: CUChar, - base_group :: CUShort, - latched_group :: CUShort, - mods :: CUChar, - base_mods :: CUChar, - latched_mods :: CUChar, - locked_mods :: CUChar, - compat_state :: CUChar, - grab_mods :: CUChar, - compat_grab_mods :: CUChar, - lookup_mods :: CUChar, - compat_lookup_mods :: CUChar, - ptr_buttons :: CUShort -} - -instance Storable XkbStateRec where - sizeOf _ = (#size XkbStateRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_group <- (#peek XkbStateRec, group) ptr - r_locked_group <- (#peek XkbStateRec, locked_group) ptr - r_base_group <- (#peek XkbStateRec, base_group) ptr - r_latched_group <- (#peek XkbStateRec, latched_group) ptr - r_mods <- (#peek XkbStateRec, mods) ptr - r_base_mods <- (#peek XkbStateRec, base_mods) ptr - r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr - r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr - r_compat_state <- (#peek XkbStateRec, compat_state) ptr - r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr - r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr - r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr - r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr - r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr - return XkbStateRec { - group = r_group, - locked_group = r_locked_group, - base_group = r_base_group, - latched_group = r_latched_group, - mods = r_mods, - base_mods = r_base_mods, - latched_mods = r_latched_mods, - locked_mods = r_locked_mods, - compat_state = r_compat_state, - grab_mods = r_grab_mods, - compat_grab_mods = r_compat_grab_mods, - lookup_mods = r_lookup_mods, - compat_lookup_mods = r_compat_lookup_mods, - ptr_buttons = r_ptr_buttons - } - -foreign import ccall unsafe "X11/XKBlib.h XkbGetState" - xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt - - -getKbdLayout :: Display -> IO Int -getKbdLayout d = alloca $ \stRecPtr -> do - xkbGetState d 0x100 stRecPtr - st <- peek stRecPtr - return $ fromIntegral (group st) - --- --- --- - -data XkbKeyNameRec = XkbKeyNameRec { - name :: Ptr CChar -- array -} - --- --- the t_ before alias is just because of name collisions --- -data XkbKeyAliasRec = XkbKeyAliasRec { - real :: Ptr CChar, -- array - t_alias :: Ptr CChar -- array -} - --- --- the t_ before geometry is just because of name collisions --- -data XkbNamesRec = XkbNamesRec { - keycodes :: Atom, - t_geometry :: Atom, - symbols :: Atom, - types :: Atom, - compat :: Atom, - vmods :: Ptr Atom, - indicators :: Ptr Atom, -- array - groups :: Ptr Atom, -- array - keys :: Ptr XkbKeyNameRec, - key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec, - radio_groups :: Ptr Atom, - phys_symbols :: Atom, - num_keys :: CUChar, - num_key_aliases :: CUChar, - num_rg :: CUShort -} - --- --- the t_ before map, indicators and compat are just because of name collisions --- -data XkbDescRec = XkbDescRec { - t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care - flags :: CUShort, - device_spec :: CUShort, - min_key_code :: KeyCode, - max_key_code :: KeyCode, - ctrls :: Ptr CChar, -- XkbControlsPtr ; dont' care - server :: Ptr CChar, -- XkbServerMapPtr ; dont' care - t_map :: Ptr CChar, --XkbClientMapPtr ; dont' care - t_indicators :: Ptr CChar, -- XkbIndicatorPtr ; dont' care - names :: Ptr XkbNamesRec, -- array - t_compat :: Ptr CChar, -- XkbCompatMap ; dont' care - geom :: Ptr CChar -- XkbGeometryPtr ; dont' care - -} - -instance Storable XkbKeyNameRec where - sizeOf _ = (#size XkbKeyNameRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_name <- (#peek XkbKeyNameRec, name) ptr - - return XkbKeyNameRec { - name = r_name - } - -instance Storable XkbKeyAliasRec where - sizeOf _ = (#size XkbKeyAliasRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_real <- (#peek XkbKeyAliasRec, real) ptr - r_alias <- (#peek XkbKeyAliasRec, alias) ptr - - return XkbKeyAliasRec { - real = r_real, - t_alias = r_alias - } - -instance Storable XkbNamesRec where - sizeOf _ = (#size XkbNamesRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_keycodes <- (#peek XkbNamesRec, keycodes) ptr - r_geometry <- (#peek XkbNamesRec, geometry) ptr - r_symbols <- (#peek XkbNamesRec, symbols ) ptr - r_types <- (#peek XkbNamesRec, types ) ptr - r_compat <- (#peek XkbNamesRec, compat ) ptr - r_vmods <- (#peek XkbNamesRec, vmods ) ptr - r_indicators <- (#peek XkbNamesRec, indicators ) ptr - r_groups <- (#peek XkbNamesRec, groups ) ptr - r_keys <- (#peek XkbNamesRec, keys ) ptr - r_key_aliases <- (#peek XkbNamesRec, key_aliases ) ptr - r_radio_groups <- (#peek XkbNamesRec, radio_groups ) ptr - r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr - r_num_keys <- (#peek XkbNamesRec,num_keys ) ptr - r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases ) ptr - r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr - - return XkbNamesRec { - keycodes = r_keycodes, - t_geometry = r_geometry, - symbols = r_symbols, - types = r_types, - compat = r_compat, - vmods = r_vmods, - indicators = r_indicators, - groups = r_groups, - keys = r_keys, - key_aliases = r_key_aliases, - radio_groups = r_radio_groups, - phys_symbols = r_phys_symbols, - num_keys = r_num_keys, - num_key_aliases = r_num_key_aliases, - num_rg = r_num_rg - } - -instance Storable XkbDescRec where - sizeOf _ = (#size XkbDescRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_dpy <- (#peek XkbDescRec, dpy) ptr - r_flags <- (#peek XkbDescRec, flags) ptr - r_device_spec <- (#peek XkbDescRec, device_spec) ptr - r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr - r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr - r_ctrls <- (#peek XkbDescRec, ctrls) ptr - r_server <- (#peek XkbDescRec, server) ptr - r_map <- (#peek XkbDescRec, map) ptr - r_indicators <- (#peek XkbDescRec, indicators) ptr - r_names <- (#peek XkbDescRec, names) ptr - r_compat <- (#peek XkbDescRec, compat) ptr - r_geom <- (#peek XkbDescRec, geom) ptr - - return XkbDescRec { - t_dpy = r_dpy, - flags = r_flags, - device_spec = r_device_spec, - min_key_code = r_min_key_code, - max_key_code = r_max_key_code, - ctrls = r_ctrls, - server = r_server, - t_map = r_map, - t_indicators = r_indicators, - names = r_names, - t_compat = r_compat, - geom = r_geom - } - --- --- C bindings --- - -foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard" - xkbAllocKeyboard :: IO (Ptr XkbDescRec) - -foreign import ccall unsafe "X11/XKBlib.h XkbGetNames" - xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec) -> IO Status - -foreign import ccall unsafe "X11/XKBlib.h XGetAtomName" - xGetAtomName :: Display -> Atom -> IO CString - -foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames" - xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () - -foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard" - xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () - -foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails" - xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt - -foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents" - xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt - - -xkbUseCoreKbd :: CUInt -xkbUseCoreKbd = #const XkbUseCoreKbd - -xkbStateNotify :: CUInt -xkbStateNotify = #const XkbStateNotify - -xkbIndicatorStateNotify :: CUInt -xkbIndicatorStateNotify = #const XkbIndicatorStateNotify - -xkbMapNotify :: CUInt -xkbMapNotify = #const XkbMapNotify - -xkbMapNotifyMask :: CUInt -xkbMapNotifyMask = #const XkbMapNotifyMask - -xkbNewKeyboardNotifyMask :: CUInt -xkbNewKeyboardNotifyMask = #const XkbNewKeyboardNotifyMask - -xkbAllStateComponentsMask :: CULong -xkbAllStateComponentsMask = #const XkbAllStateComponentsMask - -xkbGroupStateMask :: CULong -xkbGroupStateMask = #const XkbGroupStateMask - -xkbSymbolsNameMask :: CUInt -xkbSymbolsNameMask = #const XkbSymbolsNameMask - -xkbGroupNamesMask :: CUInt -xkbGroupNamesMask = #const XkbGroupNamesMask - -type KbdOpts = [(String, String)] - --- gets the layout string -getLayoutStr :: Display -> IO String -getLayoutStr dpy = do - kbdDescPtr <- xkbAllocKeyboard - status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr - str <- getLayoutStr' status dpy kbdDescPtr - xkbFreeNames kbdDescPtr xkbGroupNamesMask 1 - xkbFreeKeyboard kbdDescPtr 0 1 - return str - -getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String -getLayoutStr' st dpy kbdDescPtr = - if st == 0 then -- Success - do - kbdDesc <- peek kbdDescPtr - nameArray <- peek (names kbdDesc) - atom <- xGetAtomName dpy (symbols nameArray) - str <- peekCString atom - return str - else -- Behaviour on error - do - return "Error while requesting layout!" - - --- 'Bad' prefixes of layouts -noLaySymbols :: [String] -noLaySymbols = ["group", "inet", "ctr", "pc", "ctrl"] - - --- splits the layout string into the actual layouts -splitLayout :: String -> [String] -splitLayout s = splitLayout' noLaySymbols $ split s '+' - -splitLayout' :: [String] -> [String] -> [String] --- end of recursion, remove empty strings -splitLayout' [] s = map (takeWhile (\x -> x /= ':')) $ filter (\x -> length x > 0) s --- remove current string if it has a 'bad' prefix -splitLayout' bad s = splitLayout' (tail bad) [x | x <- s, not $ isPrefixOf (head bad) x] - --- split String at each Char -split :: String -> Char -> [String] -split [] _ = [""] -split (c:cs) delim - | c == delim = "" : rest - | otherwise = (c : head rest) : tail rest - where - rest = split cs delim - --- replaces input string if on search list (exact match) with corresponding --- element on replacement list. --- --- if not found, return string unchanged -searchReplaceLayout :: KbdOpts -> String -> String -searchReplaceLayout opts s = let c = findIndex (\x -> fst x == s) opts in - case c of - Nothing -> s - x -> let i = (fromJust x) in - snd $ opts!!i - --- returns the active layout -getKbdLay :: Display -> KbdOpts -> IO String -getKbdLay dpy opts = do - lay <- getLayoutStr dpy - curLay <- getKbdLayout dpy - return $ searchReplaceLayout opts $ (splitLayout lay)!!(curLay) - - - -data Kbd = Kbd [(String, String)] - deriving (Read, Show) - -instance Exec Kbd where - alias (Kbd _) = "kbd" - start (Kbd opts) cb = do - - dpy <- openDisplay "" - - -- initial set of layout - cb =<< getKbdLay dpy opts - - -- enable listing for - -- group changes - _ <- xkbSelectEventDetails dpy xkbUseCoreKbd xkbStateNotify xkbAllStateComponentsMask xkbGroupStateMask - -- layout/geometry changes - _ <- xkbSelectEvents dpy xkbUseCoreKbd xkbNewKeyboardNotifyMask xkbNewKeyboardNotifyMask - - allocaXEvent $ \e -> forever $ do - nextEvent' dpy e - _ <- getEvent e - cb =<< getKbdLay dpy opts - - closeDisplay dpy - return () - --- vim:ft=haskell:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20: diff --git a/src/Xmobar/Plugins/Locks.hs b/src/Xmobar/Plugins/Locks.hs deleted file mode 100644 index 9a971e5..0000000 --- a/src/Xmobar/Plugins/Locks.hs +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Locks --- Copyright : (c) Patrick Chilton --- License : BSD-style (see LICENSE) --- --- Maintainer : Patrick Chilton <chpatrick@gmail.com> --- Stability : unstable --- Portability : unportable --- --- A plugin that displays the status of the lock keys. --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Locks where - -import Graphics.X11 -import Data.List -import Data.Bits -import Control.Monad -import Graphics.X11.Xlib.Extras -import Xmobar.Plugins -import Xmobar.Plugins.Kbd -import Xmobar.XUtil (nextEvent') - -data Locks = Locks - deriving (Read, Show) - -locks :: [ ( KeySym, String )] -locks = [ ( xK_Caps_Lock, "CAPS" ) - , ( xK_Num_Lock, "NUM" ) - , ( xK_Scroll_Lock, "SCROLL" ) - ] - -run' :: Display -> Window -> IO String -run' d root = do - modMap <- getModifierMapping d - ( _, _, _, _, _, _, _, m ) <- queryPointer d root - - ls <- filterM ( \( ks, _ ) -> do - kc <- keysymToKeycode d ks - return $ case find (elem kc . snd) modMap of - Nothing -> False - Just ( i, _ ) -> testBit m (fromIntegral i) - ) locks - - return $ unwords $ map snd ls - -instance Exec Locks where - alias Locks = "locks" - start Locks cb = do - d <- openDisplay "" - root <- rootWindow d (defaultScreen d) - _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m - - allocaXEvent $ \ep -> forever $ do - cb =<< run' d root - nextEvent' d ep - getEvent ep - - closeDisplay d - return () - where - m = xkbAllStateComponentsMask diff --git a/src/Xmobar/Plugins/MBox.hs b/src/Xmobar/Plugins/MBox.hs deleted file mode 100644 index 2281629..0000000 --- a/src/Xmobar/Plugins/MBox.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.MBox --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A plugin for checking mail in mbox files. --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.MBox (MBox(..)) where - -import Prelude -import Xmobar.Plugins -#ifdef INOTIFY -import Xmobar.Plugins.Utils (changeLoop, expandHome) - -import Control.Monad (when) -import Control.Concurrent.STM -import Control.Exception (SomeException (..), handle, evaluate) - -import System.Console.GetOpt -import System.Directory (doesFileExist) -import System.FilePath ((</>)) -import System.INotify (Event(..), EventVariety(..), initINotify, addWatch) - -import qualified Data.ByteString.Lazy.Char8 as B - -#if MIN_VERSION_hinotify(0,3,10) -import qualified Data.ByteString.Char8 as BS (ByteString, pack) -pack :: String -> BS.ByteString -pack = BS.pack -#else -pack :: String -> String -pack = id -#endif - -data Options = Options - { oAll :: Bool - , oUniq :: Bool - , oDir :: FilePath - , oPrefix :: String - , oSuffix :: String - } - -defaults :: Options -defaults = Options { - oAll = False, oUniq = False, oDir = "", oPrefix = "", oSuffix = "" - } - -options :: [OptDescr (Options -> Options)] -options = - [ Option "a" ["all"] (NoArg (\o -> o { oAll = True })) "" - , Option "u" [] (NoArg (\o -> o { oUniq = True })) "" - , Option "d" ["dir"] (ReqArg (\x o -> o { oDir = x }) "") "" - , Option "p" ["prefix"] (ReqArg (\x o -> o { oPrefix = x }) "") "" - , Option "s" ["suffix"] (ReqArg (\x o -> o { oSuffix = x }) "") "" - ] - -parseOptions :: [String] -> IO Options -parseOptions args = - case getOpt Permute options args of - (o, _, []) -> return $ foldr id defaults o - (_, _, errs) -> ioError . userError $ concat errs - -#else -import System.IO -#endif - --- | A list of display names, paths to mbox files and display colours, --- followed by a list of options. -data MBox = MBox [(String, FilePath, String)] [String] String - deriving (Read, Show) - -instance Exec MBox where - alias (MBox _ _ a) = a -#ifndef INOTIFY - start _ _ = - hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify" ++ - " but the MBox plugin requires it" -#else - start (MBox boxes args _) cb = do - opts <- parseOptions args - let showAll = oAll opts - prefix = oPrefix opts - suffix = oSuffix opts - uniq = oUniq opts - names = map (\(t, _, _) -> t) boxes - colors = map (\(_, _, c) -> c) boxes - extractPath (_, f, _) = expandHome $ oDir opts </> f - events = [CloseWrite] - - i <- initINotify - vs <- mapM (\b -> do - f <- extractPath b - exists <- doesFileExist f - n <- if exists then countMails f else return (-1) - v <- newTVarIO (f, n) - when exists $ - addWatch i events (pack f) (handleNotification v) >> return () - return v) - boxes - - changeLoop (mapM (fmap snd . readTVar) vs) $ \ns -> - let s = unwords [ showC uniq m n c | (m, n, c) <- zip3 names ns colors - , showAll || n > 0 ] - in cb (if null s then "" else prefix ++ s ++ suffix) - -showC :: Bool -> String -> Int -> String -> String -showC u m n c = - if c == "" then msg else "<fc=" ++ c ++ ">" ++ msg ++ "</fc>" - where msg = m ++ if not u || n > 1 then show n else "" - -countMails :: FilePath -> IO Int -countMails f = - handle (\(SomeException _) -> evaluate 0) - (do txt <- B.readFile f - evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt) - where from = B.pack "From " - -handleNotification :: TVar (FilePath, Int) -> Event -> IO () -handleNotification v _ = do - (p, _) <- atomically $ readTVar v - n <- countMails p - atomically $ writeTVar v (p, n) -#endif diff --git a/src/Xmobar/Plugins/Mail.hs b/src/Xmobar/Plugins/Mail.hs deleted file mode 100644 index c41b5b3..0000000 --- a/src/Xmobar/Plugins/Mail.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Mail --- Copyright : (c) Spencer Janssen --- License : BSD-style (see LICENSE) --- --- Maintainer : Spencer Janssen <sjanssen@cse.unl.edu> --- Stability : unstable --- Portability : unportable --- --- A plugin for checking mail. --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Mail where - -import Xmobar.Plugins -#ifdef INOTIFY -import Xmobar.Plugins.Utils (expandHome, changeLoop) - -import Control.Monad -import Control.Concurrent.STM - -import System.Directory -import System.FilePath -import System.INotify - -import Data.List (isPrefixOf) -import Data.Set (Set) -import qualified Data.Set as S - -#if MIN_VERSION_hinotify(0,3,10) -import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack) -unpack :: BS.ByteString -> String -unpack = BS.unpack -pack :: String -> BS.ByteString -pack = BS.pack -#else -unpack :: String -> String -unpack = id -pack :: String -> String -pack = id -#endif -#else -import System.IO -#endif - - --- | A list of mail box names and paths to maildirs. -data Mail = Mail [(String, FilePath)] String - deriving (Read, Show) - -instance Exec Mail where - alias (Mail _ a) = a -#ifndef INOTIFY - start _ _ = - hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify," - ++ " but the Mail plugin requires it." -#else - start (Mail ms _) cb = do - vs <- mapM (const $ newTVarIO S.empty) ms - - let ts = map fst ms - rs = map ((</> "new") . snd) ms - ev = [Move, MoveIn, MoveOut, Create, Delete] - - ds <- mapM expandHome rs - i <- initINotify - zipWithM_ (\d v -> addWatch i ev d (handle v)) (map pack ds) vs - - forM_ (zip ds vs) $ \(d, v) -> do - s <- fmap (S.fromList . filter (not . isPrefixOf ".")) - $ getDirectoryContents d - atomically $ modifyTVar v (S.union s) - - changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns -> - cb . unwords $ [m ++ show n - | (m, n) <- zip ts ns - , n /= 0 ] - -handle :: TVar (Set String) -> Event -> IO () -handle v e = atomically $ modifyTVar v $ case e of - Created {} -> create - MovedIn {} -> create - Deleted {} -> delete - MovedOut {} -> delete - _ -> id - where - delete = S.delete ((unpack . filePath) e) - create = S.insert ((unpack . filePath) e) -#endif diff --git a/src/Xmobar/Plugins/MarqueePipeReader.hs b/src/Xmobar/Plugins/MarqueePipeReader.hs deleted file mode 100644 index ad6f27f..0000000 --- a/src/Xmobar/Plugins/MarqueePipeReader.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.MarqueePipeReader --- Copyright : (c) Reto Habluetzel --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from named pipes for long texts with marquee --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.MarqueePipeReader where - -import System.IO (openFile, IOMode(ReadWriteMode), Handle) -import Xmobar.Environment -import Xmobar.Plugins (tenthSeconds, Exec(alias, start), hGetLineSafe) -import System.Posix.Files (getFileStatus, isNamedPipe) -import Control.Concurrent(forkIO, threadDelay) -import Control.Concurrent.STM (TChan, atomically, writeTChan, tryReadTChan, newTChan) -import Control.Exception -import Control.Monad(forever, unless) -import Control.Applicative ((<$>)) - -type Length = Int -- length of the text to display -type Rate = Int -- delay in tenth seconds -type Separator = String -- if text wraps around, use separator - -data MarqueePipeReader = MarqueePipeReader String (Length, Rate, Separator) String - deriving (Read, Show) - -instance Exec MarqueePipeReader where - alias (MarqueePipeReader _ _ a) = a - start (MarqueePipeReader p (len, rate, sep) _) cb = do - (def, pipe) <- split ':' <$> expandEnv p - unless (null def) (cb def) - checkPipe pipe - h <- openFile pipe ReadWriteMode - line <- hGetLineSafe h - chan <- atomically newTChan - forkIO $ writer (toInfTxt line sep) sep len rate chan cb - forever $ pipeToChan h chan - where - split c xs | c `elem` xs = let (pre, post) = span (c /=) xs - in (pre, dropWhile (c ==) post) - | otherwise = ([], xs) - -pipeToChan :: Handle -> TChan String -> IO () -pipeToChan h chan = do - line <- hGetLineSafe h - atomically $ writeTChan chan line - -writer :: String -> Separator -> Length -> Rate -> TChan String -> (String -> IO ()) -> IO () -writer txt sep len rate chan cb = do - cb (take len txt) - mbnext <- atomically $ tryReadTChan chan - case mbnext of - Just new -> writer (toInfTxt new sep) sep len rate chan cb - Nothing -> tenthSeconds rate >> writer (drop 1 txt) sep len rate chan cb - -toInfTxt :: String -> String -> String -toInfTxt line sep = concat (repeat $ line ++ " " ++ sep ++ " ") - -checkPipe :: FilePath -> IO () -checkPipe file = handle (\(SomeException _) -> waitForPipe) $ do - status <- getFileStatus file - unless (isNamedPipe status) waitForPipe - where waitForPipe = threadDelay 1000 >> checkPipe file diff --git a/src/Xmobar/Plugins/Monitors.hs b/src/Xmobar/Plugins/Monitors.hs deleted file mode 100644 index 64d38f0..0000000 --- a/src/Xmobar/Plugins/Monitors.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Plugins.Monitors --- Copyright : (c) 2010, 2011, 2012, 2013, 2017, 2018 Jose Antonio Ortega Ruiz --- (c) 2007-10 Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- The system monitor plugin for Xmobar. --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Monitors where - -import Xmobar.Plugins - -import Xmobar.Plugins.Monitors.Common (runM, runMD) -#ifdef WEATHER -import Xmobar.Plugins.Monitors.Weather -#endif -import Xmobar.Plugins.Monitors.Net -import Xmobar.Plugins.Monitors.Mem -import Xmobar.Plugins.Monitors.Swap -import Xmobar.Plugins.Monitors.Cpu -import Xmobar.Plugins.Monitors.MultiCpu -import Xmobar.Plugins.Monitors.Batt -import Xmobar.Plugins.Monitors.Bright -import Xmobar.Plugins.Monitors.Thermal -import Xmobar.Plugins.Monitors.ThermalZone -import Xmobar.Plugins.Monitors.CpuFreq -import Xmobar.Plugins.Monitors.CoreTemp -import Xmobar.Plugins.Monitors.Disk -import Xmobar.Plugins.Monitors.Top -import Xmobar.Plugins.Monitors.Uptime -import Xmobar.Plugins.Monitors.CatInt -#ifdef UVMETER -import Xmobar.Plugins.Monitors.UVMeter -#endif -#ifdef IWLIB -import Xmobar.Plugins.Monitors.Wireless -#endif -#ifdef LIBMPD -import Xmobar.Plugins.Monitors.MPD -import Xmobar.Plugins.Monitors.Common (runMBD) -#endif -#ifdef ALSA -import Xmobar.Plugins.Monitors.Volume -import Xmobar.Plugins.Monitors.Alsa -#endif -#ifdef MPRIS -import Xmobar.Plugins.Monitors.Mpris -#endif - -data Monitors = Network Interface Args Rate - | DynNetwork Args Rate - | BatteryP Args Args Rate - | BatteryN Args Args Rate Alias - | Battery Args Rate - | DiskU DiskSpec Args Rate - | DiskIO DiskSpec Args Rate - | Thermal Zone Args Rate - | ThermalZone ZoneNo Args Rate - | Memory Args Rate - | Swap Args Rate - | Cpu Args Rate - | MultiCpu Args Rate - | Brightness Args Rate - | CpuFreq Args Rate - | CoreTemp Args Rate - | TopProc Args Rate - | TopMem Args Rate - | Uptime Args Rate - | CatInt Int FilePath Args Rate -#ifdef WEATHER - | Weather Station Args Rate -#endif -#ifdef UVMETER - | UVMeter Station Args Rate -#endif -#ifdef IWLIB - | Wireless Interface Args Rate -#endif -#ifdef LIBMPD - | MPD Args Rate - | AutoMPD Args -#endif -#ifdef ALSA - | Volume String String Args Rate - | Alsa String String Args -#endif -#ifdef MPRIS - | Mpris1 String Args Rate - | Mpris2 String Args Rate -#endif - deriving (Show,Read,Eq) - -type Args = [String] -type Program = String -type Alias = String -type Station = String -type Zone = String -type ZoneNo = Int -type Interface = String -type Rate = Int -type DiskSpec = [(String, String)] - -instance Exec Monitors where -#ifdef WEATHER - alias (Weather s _ _) = s -#endif - alias (Network i _ _) = i - alias (DynNetwork _ _) = "dynnetwork" - alias (Thermal z _ _) = z - alias (ThermalZone z _ _) = "thermal" ++ show z - alias (Memory _ _) = "memory" - alias (Swap _ _) = "swap" - alias (Cpu _ _) = "cpu" - alias (MultiCpu _ _) = "multicpu" - alias (Battery _ _) = "battery" - alias BatteryP {} = "battery" - alias (BatteryN _ _ _ a)= a - alias (Brightness _ _) = "bright" - alias (CpuFreq _ _) = "cpufreq" - alias (TopProc _ _) = "top" - alias (TopMem _ _) = "topmem" - alias (CoreTemp _ _) = "coretemp" - alias DiskU {} = "disku" - alias DiskIO {} = "diskio" - alias (Uptime _ _) = "uptime" - alias (CatInt n _ _ _) = "cat" ++ show n -#ifdef UVMETER - alias (UVMeter s _ _) = "uv " ++ s -#endif -#ifdef IWLIB - alias (Wireless i _ _) = i ++ "wi" -#endif -#ifdef LIBMPD - alias (MPD _ _) = "mpd" - alias (AutoMPD _) = "autompd" -#endif -#ifdef ALSA - alias (Volume m c _ _) = m ++ ":" ++ c - alias (Alsa m c _) = "alsa:" ++ m ++ ":" ++ c -#endif -#ifdef MPRIS - alias (Mpris1 _ _ _) = "mpris1" - alias (Mpris2 _ _ _) = "mpris2" -#endif - start (Network i a r) = startNet i a r - start (DynNetwork a r) = startDynNet a r - start (Cpu a r) = startCpu a r - start (MultiCpu a r) = startMultiCpu a r - start (TopProc a r) = startTop a r - start (TopMem a r) = runM a topMemConfig runTopMem r -#ifdef WEATHER - start (Weather s a r) = runMD (a ++ [s]) weatherConfig runWeather r weatherReady -#endif - start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r - start (ThermalZone z a r) = - runM (a ++ [show z]) thermalZoneConfig runThermalZone r - start (Memory a r) = runM a memConfig runMem r - start (Swap a r) = runM a swapConfig runSwap r - start (Battery a r) = runM a battConfig runBatt r - start (BatteryP s a r) = runM a battConfig (runBatt' s) r - start (BatteryN s a r _) = runM a battConfig (runBatt' s) r - start (Brightness a r) = runM a brightConfig runBright r - start (CpuFreq a r) = runM a cpuFreqConfig runCpuFreq r - start (CoreTemp a r) = runM a coreTempConfig runCoreTemp r - start (DiskU s a r) = runM a diskUConfig (runDiskU s) r - start (DiskIO s a r) = startDiskIO s a r - start (Uptime a r) = runM a uptimeConfig runUptime r - start (CatInt _ s a r) = runM a catIntConfig (runCatInt s) r -#ifdef UVMETER - start (UVMeter s a r) = runM (a ++ [s]) uvConfig runUVMeter r -#endif -#ifdef IWLIB - start (Wireless i a r) = runM a wirelessConfig (runWireless i) r -#endif -#ifdef LIBMPD - start (MPD a r) = runMD a mpdConfig runMPD r mpdReady - start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady -#endif -#ifdef ALSA - start (Volume m c a r) = runM a volumeConfig (runVolume m c) r - start (Alsa m c a) = startAlsaPlugin m c a -#endif -#ifdef MPRIS - start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r - start (Mpris2 s a r) = runM a mprisConfig (runMPRIS2 s) r -#endif diff --git a/src/Xmobar/Plugins/Monitors/Alsa.hs b/src/Xmobar/Plugins/Monitors/Alsa.hs deleted file mode 100644 index 21a2786..0000000 --- a/src/Xmobar/Plugins/Monitors/Alsa.hs +++ /dev/null @@ -1,146 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index 80f4275..0000000 --- a/src/Xmobar/Plugins/Monitors/Batt.hs +++ /dev/null @@ -1,247 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Batt --- Copyright : (c) 2010, 2011, 2012, 2013, 2015, 2016, 2018 Jose A Ortega --- (c) 2010 Andrea Rossato, Petr Rockai --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <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 deleted file mode 100644 index fe72219..0000000 --- a/src/Xmobar/Plugins/Monitors/Bright.hs +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------ ----- | ----- Module : Plugins.Monitors.Birght ----- Copyright : (c) Martin Perner ----- License : BSD-style (see LICENSE) ----- ----- Maintainer : Martin Perner <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 deleted file mode 100644 index 781eded..0000000 --- a/src/Xmobar/Plugins/Monitors/CatInt.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CatInt --- Copyright : (c) Nathaniel Wesley Filardo --- License : BSD-style (see LICENSE) --- --- Maintainer : Nathaniel Wesley Filardo --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index 272690b..0000000 --- a/src/Xmobar/Plugins/Monitors/Common.hs +++ /dev/null @@ -1,544 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Common --- Copyright : (c) 2010, 2011, 2013, 2016, 2017, 2018 Jose Antonio Ortega Ruiz --- (c) 2007-2010 Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Utilities used by xmobar's monitors --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Monitors.Common ( - -- * Monitors - -- $monitor - Monitor - , MConfig (..) - , Opts (..) - , setConfigValue - , getConfigValue - , mkMConfig - , runM - , runMD - , runMB - , runMBD - , io - -- * Parsers - -- $parsers - , runP - , skipRestOfLine - , getNumbers - , getNumbersAsString - , getAllBut - , getAfterString - , skipTillString - , parseTemplate - , parseTemplate' - -- ** String Manipulation - -- $strings - , IconPattern - , parseIconPattern - , padString - , showWithPadding - , showWithColors - , showWithColors' - , showPercentWithColors - , showPercentsWithColors - , showPercentBar - , showVerticalBar - , showIconPattern - , showLogBar - , showLogVBar - , showLogIconPattern - , showWithUnits - , takeDigits - , showDigits - , floatToPercent - , parseFloat - , parseInt - , stringParser - ) where - - -import Control.Applicative ((<$>)) -import Control.Monad.Reader -import qualified Data.ByteString.Lazy.Char8 as B -import Data.IORef -import qualified Data.Map as Map -import Data.List -import Data.Char -import Numeric -import Text.ParserCombinators.Parsec -import System.Console.GetOpt -import Control.Exception (SomeException,handle) - -import Xmobar.Plugins --- $monitor - -type Monitor a = ReaderT MConfig IO a - -data MConfig = - MC { normalColor :: IORef (Maybe String) - , low :: IORef Int - , lowColor :: IORef (Maybe String) - , high :: IORef Int - , highColor :: IORef (Maybe String) - , template :: IORef String - , export :: IORef [String] - , ppad :: IORef Int - , decDigits :: IORef Int - , minWidth :: IORef Int - , maxWidth :: IORef Int - , maxWidthEllipsis :: IORef String - , padChars :: IORef String - , padRight :: IORef Bool - , barBack :: IORef String - , barFore :: IORef String - , barWidth :: IORef Int - , useSuffix :: IORef Bool - , naString :: IORef String - , maxTotalWidth :: IORef Int - , maxTotalWidthEllipsis :: IORef String - } - --- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' -type Selector a = MConfig -> IORef a - -sel :: Selector a -> Monitor a -sel s = - do hs <- ask - liftIO $ readIORef (s hs) - -mods :: Selector a -> (a -> a) -> Monitor () -mods s m = - do v <- ask - io $ modifyIORef (s v) m - -setConfigValue :: a -> Selector a -> Monitor () -setConfigValue v s = - mods s (const v) - -getConfigValue :: Selector a -> Monitor a -getConfigValue = sel - -mkMConfig :: String - -> [String] - -> IO MConfig -mkMConfig tmpl exprts = - do lc <- newIORef Nothing - l <- newIORef 33 - nc <- newIORef Nothing - h <- newIORef 66 - hc <- newIORef Nothing - t <- newIORef tmpl - e <- newIORef exprts - p <- newIORef 0 - d <- newIORef 0 - mn <- newIORef 0 - mx <- newIORef 0 - mel <- newIORef "" - pc <- newIORef " " - pr <- newIORef False - bb <- newIORef ":" - bf <- newIORef "#" - bw <- newIORef 10 - up <- newIORef False - na <- newIORef "N/A" - mt <- newIORef 0 - mtel <- newIORef "" - return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel - -data Opts = HighColor String - | NormalColor String - | LowColor String - | Low String - | High String - | Template String - | PercentPad String - | DecDigits String - | MinWidth String - | MaxWidth String - | Width String - | WidthEllipsis String - | PadChars String - | PadAlign String - | BarBack String - | BarFore String - | BarWidth String - | UseSuffix String - | NAString String - | MaxTotalWidth String - | MaxTotalWidthEllipsis String - -options :: [OptDescr Opts] -options = - [ - Option "H" ["High"] (ReqArg High "number") "The high threshold" - , Option "L" ["Low"] (ReqArg Low "number") "The low threshold" - , Option "h" ["high"] (ReqArg HighColor "color number") "Color for the high threshold: ex \"#FF0000\"" - , Option "n" ["normal"] (ReqArg NormalColor "color number") "Color for the normal threshold: ex \"#00FF00\"" - , Option "l" ["low"] (ReqArg LowColor "color number") "Color for the low threshold: ex \"#0000FF\"" - , Option "t" ["template"] (ReqArg Template "output template") "Output template." - , Option "S" ["suffix"] (ReqArg UseSuffix "True/False") "Use % to display percents or other suffixes." - , Option "d" ["ddigits"] (ReqArg DecDigits "decimal digits") "Number of decimal digits to display." - , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width." - , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width") "Minimum field width" - , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width") "Maximum field width" - , Option "w" ["width"] (ReqArg Width "fixed width") "Fixed field width" - , Option "e" ["maxwidthellipsis"] (ReqArg WidthEllipsis "Maximum width ellipsis") "Ellipsis to be added to the field when it has reached its max width." - , Option "c" ["padchars"] (ReqArg PadChars "padding chars") "Characters to use for padding" - , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right" - , Option "b" ["bback"] (ReqArg BarBack "bar background") "Characters used to draw bar backgrounds" - , Option "f" ["bfore"] (ReqArg BarFore "bar foreground") "Characters used to draw bar foregrounds" - , Option "W" ["bwidth"] (ReqArg BarWidth "bar width") "Bar width" - , Option "x" ["nastring"] (ReqArg NAString "N/A string") "String used when the monitor is not available" - , Option "T" ["maxtwidth"] (ReqArg MaxTotalWidth "Maximum total width") "Maximum total width" - , Option "E" ["maxtwidthellipsis"] (ReqArg MaxTotalWidthEllipsis "Maximum total width ellipsis") "Ellipsis to be added to the total text when it has reached its max width." - ] - -doArgs :: [String] -> ([String] -> Monitor String) -> ([String] -> Monitor Bool) -> Monitor String -doArgs args action detect = - case getOpt Permute options args of - (o, n, []) -> do doConfigOptions o - ready <- detect n - if ready - then action n - else return "<Waiting...>" - (_, _, errs) -> return (concat errs) - -doConfigOptions :: [Opts] -> Monitor () -doConfigOptions [] = io $ return () -doConfigOptions (o:oo) = - do let next = doConfigOptions oo - nz s = let x = read s in max 0 x - bool = (`elem` ["True", "true", "Yes", "yes", "On", "on"]) - (case o of - High h -> setConfigValue (read h) high - Low l -> setConfigValue (read l) low - HighColor c -> setConfigValue (Just c) highColor - NormalColor c -> setConfigValue (Just c) normalColor - LowColor c -> setConfigValue (Just c) lowColor - Template t -> setConfigValue t template - PercentPad p -> setConfigValue (nz p) ppad - DecDigits d -> setConfigValue (nz d) decDigits - MinWidth w -> setConfigValue (nz w) minWidth - MaxWidth w -> setConfigValue (nz w) maxWidth - Width w -> setConfigValue (nz w) minWidth >> - setConfigValue (nz w) maxWidth - WidthEllipsis e -> setConfigValue e maxWidthEllipsis - PadChars s -> setConfigValue s padChars - PadAlign a -> setConfigValue ("r" `isPrefixOf` a) padRight - BarBack s -> setConfigValue s barBack - BarFore s -> setConfigValue s barFore - BarWidth w -> setConfigValue (nz w) barWidth - UseSuffix u -> setConfigValue (bool u) useSuffix - NAString s -> setConfigValue s naString - MaxTotalWidth w -> setConfigValue (nz w) maxTotalWidth - MaxTotalWidthEllipsis e -> setConfigValue e maxTotalWidthEllipsis) >> next - -runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int - -> (String -> IO ()) -> IO () -runM args conf action r = runMB args conf action (tenthSeconds r) - -runMD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int - -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () -runMD args conf action r = runMBD args conf action (tenthSeconds r) - -runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () - -> (String -> IO ()) -> IO () -runMB args conf action wait = runMBD args conf action wait (\_ -> return True) - -runMBD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () - -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () -runMBD args conf action wait detect cb = handle (cb . showException) loop - where ac = doArgs args action detect - loop = conf >>= runReaderT ac >>= cb >> wait >> loop - -showException :: SomeException -> String -showException = ("error: "++) . show . flip asTypeOf undefined - -io :: IO a -> Monitor a -io = liftIO - --- $parsers - -runP :: Parser [a] -> String -> IO [a] -runP p i = - case parse p "" i of - Left _ -> return [] - Right x -> return x - -getAllBut :: String -> Parser String -getAllBut s = - manyTill (noneOf s) (char $ head s) - -getNumbers :: Parser Float -getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n - -getNumbersAsString :: Parser String -getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n - -skipRestOfLine :: Parser Char -skipRestOfLine = - do many $ noneOf "\n\r" - newline - -getAfterString :: String -> Parser String -getAfterString s = - do { try $ manyTill skipRestOfLine $ string s - ; manyTill anyChar newline - } <|> return "" - -skipTillString :: String -> Parser String -skipTillString s = - manyTill skipRestOfLine $ string s - --- | Parses the output template string -templateStringParser :: Parser (String,String,String) -templateStringParser = - do { s <- nonPlaceHolder - ; com <- templateCommandParser - ; ss <- nonPlaceHolder - ; return (s, com, ss) - } - where - nonPlaceHolder = fmap concat . many $ - many1 (noneOf "<") <|> colorSpec <|> iconSpec - --- | Recognizes color specification and returns it unchanged -colorSpec :: Parser String -colorSpec = try (string "</fc>") <|> try ( - do string "<fc=" - s <- many1 (alphaNum <|> char ',' <|> char '#') - char '>' - return $ "<fc=" ++ s ++ ">") - --- | Recognizes icon specification and returns it unchanged -iconSpec :: Parser String -iconSpec = try (do string "<icon=" - i <- manyTill (noneOf ">") (try (string "/>")) - return $ "<icon=" ++ i ++ "/>") - --- | Parses the command part of the template string -templateCommandParser :: Parser String -templateCommandParser = - do { char '<' - ; com <- many $ noneOf ">" - ; char '>' - ; return com - } - --- | Combines the template parsers -templateParser :: Parser [(String,String,String)] -templateParser = many templateStringParser --"%") - -trimTo :: Int -> String -> String -> (Int, String) -trimTo n p "" = (n, p) -trimTo n p ('<':cs) = trimTo n p' s - where p' = p ++ "<" ++ takeWhile (/= '>') cs ++ ">" - s = drop 1 (dropWhile (/= '>') cs) -trimTo 0 p s = trimTo 0 p (dropWhile (/= '<') s) -trimTo n p s = let p' = takeWhile (/= '<') s - s' = dropWhile (/= '<') s - in - if length p' <= n - then trimTo (n - length p') (p ++ p') s' - else trimTo 0 (p ++ take n p') s' - --- | Takes a list of strings that represent the values of the exported --- keys. The strings are joined with the exported keys to form a map --- to be combined with 'combine' to the parsed template. Returns the --- final output of the monitor, trimmed to MaxTotalWidth if that --- configuration value is positive. -parseTemplate :: [String] -> Monitor String -parseTemplate l = - do t <- getConfigValue template - e <- getConfigValue export - w <- getConfigValue maxTotalWidth - ell <- getConfigValue maxTotalWidthEllipsis - let m = Map.fromList . zip e $ l - s <- parseTemplate' t m - let (n, s') = if w > 0 && length s > w - then trimTo (w - length ell) "" s - else (1, s) - return $ if n > 0 then s' else s' ++ ell - --- | Parses the template given to it with a map of export values and combines --- them -parseTemplate' :: String -> Map.Map String String -> Monitor String -parseTemplate' t m = - do s <- io $ runP templateParser t - combine m s - --- | Given a finite "Map" and a parsed template t produces the --- | resulting output string as the output of the monitor. -combine :: Map.Map String String -> [(String, String, String)] -> Monitor String -combine _ [] = return [] -combine m ((s,ts,ss):xs) = - do next <- combine m xs - str <- case Map.lookup ts m of - Nothing -> return $ "<" ++ ts ++ ">" - Just r -> let f "" = r; f n = n; in f <$> parseTemplate' r m - return $ s ++ str ++ ss ++ next - --- $strings - -type IconPattern = Int -> String - -parseIconPattern :: String -> IconPattern -parseIconPattern path = - let spl = splitOnPercent path - in \i -> intercalate (show i) spl - where splitOnPercent [] = [[]] - splitOnPercent ('%':'%':xs) = [] : splitOnPercent xs - splitOnPercent (x:xs) = - let rest = splitOnPercent xs - in (x : head rest) : tail rest - -type Pos = (Int, Int) - -takeDigits :: Int -> Float -> Float -takeDigits d n = - fromIntegral (round (n * fact) :: Int) / fact - where fact = 10 ^ d - -showDigits :: (RealFloat a) => Int -> a -> String -showDigits d n = showFFloat (Just d) n "" - -showWithUnits :: Int -> Int -> Float -> String -showWithUnits d n x - | x < 0 = '-' : showWithUnits d n (-x) - | n > 3 || x < 10^(d + 1) = show (round x :: Int) ++ units n - | x <= 1024 = showDigits d (x/1024) ++ units (n+1) - | otherwise = showWithUnits d (n+1) (x/1024) - where units = (!!) ["B", "K", "M", "G", "T"] - -padString :: Int -> Int -> String -> Bool -> String -> String -> String -padString mnw mxw pad pr ellipsis s = - let len = length s - rmin = if mnw <= 0 then 1 else mnw - rmax = if mxw <= 0 then max len rmin else mxw - (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin) - rlen = min (max rmn len) rmx - in if rlen < len then - take rlen s ++ ellipsis - else let ps = take (rlen - len) (cycle pad) - in if pr then s ++ ps else ps ++ s - -parseFloat :: String -> Float -parseFloat s = case readFloat s of - (v, _):_ -> v - _ -> 0 - -parseInt :: String -> Int -parseInt s = case readDec s of - (v, _):_ -> v - _ -> 0 - -floatToPercent :: Float -> Monitor String -floatToPercent n = - do pad <- getConfigValue ppad - pc <- getConfigValue padChars - pr <- getConfigValue padRight - up <- getConfigValue useSuffix - let p = showDigits 0 (n * 100) - ps = if up then "%" else "" - return $ padString pad pad pc pr "" p ++ ps - -stringParser :: Pos -> B.ByteString -> String -stringParser (x,y) = - B.unpack . li x . B.words . li y . B.lines - where li i l | length l > i = l !! i - | otherwise = B.empty - -setColor :: String -> Selector (Maybe String) -> Monitor String -setColor str s = - do a <- getConfigValue s - case a of - Nothing -> return str - Just c -> return $ - "<fc=" ++ c ++ ">" ++ str ++ "</fc>" - -showWithPadding :: String -> Monitor String -showWithPadding s = - do mn <- getConfigValue minWidth - mx <- getConfigValue maxWidth - p <- getConfigValue padChars - pr <- getConfigValue padRight - ellipsis <- getConfigValue maxWidthEllipsis - return $ padString mn mx p pr ellipsis s - -colorizeString :: (Num a, Ord a) => a -> String -> Monitor String -colorizeString x s = do - h <- getConfigValue high - l <- getConfigValue low - let col = setColor s - [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low - head $ [col highColor | x > hh ] ++ - [col normalColor | x > ll ] ++ - [col lowColor | True] - -showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String -showWithColors f x = showWithPadding (f x) >>= colorizeString x - -showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String -showWithColors' str = showWithColors (const str) - -showPercentsWithColors :: [Float] -> Monitor [String] -showPercentsWithColors fs = - do fstrs <- mapM floatToPercent fs - zipWithM (showWithColors . const) fstrs (map (*100) fs) - -showPercentWithColors :: Float -> Monitor String -showPercentWithColors f = fmap head $ showPercentsWithColors [f] - -showPercentBar :: Float -> Float -> Monitor String -showPercentBar v x = do - bb <- getConfigValue barBack - bf <- getConfigValue barFore - bw <- getConfigValue barWidth - let len = min bw $ round (fromIntegral bw * x) - s <- colorizeString v (take len $ cycle bf) - return $ s ++ take (bw - len) (cycle bb) - -showIconPattern :: Maybe IconPattern -> Float -> Monitor String -showIconPattern Nothing _ = return "" -showIconPattern (Just str) x = return $ str $ convert $ 100 * x - where convert val - | t <= 0 = 0 - | t > 8 = 8 - | otherwise = t - where t = round val `div` 12 - -showVerticalBar :: Float -> Float -> Monitor String -showVerticalBar v x = colorizeString v [convert $ 100 * x] - where convert :: Float -> Char - convert val - | t <= 9600 = ' ' - | t > 9608 = chr 9608 - | otherwise = chr t - where t = 9600 + (round val `div` 12) - -logScaling :: Float -> Float -> Monitor Float -logScaling f v = do - h <- fromIntegral `fmap` getConfigValue high - l <- fromIntegral `fmap` getConfigValue low - bw <- fromIntegral `fmap` getConfigValue barWidth - let [ll, hh] = sort [l, h] - scaled x | x == 0.0 = 0 - | x <= ll = 1 / bw - | otherwise = f + logBase 2 (x / hh) / bw - return $ scaled v - -showLogBar :: Float -> Float -> Monitor String -showLogBar f v = logScaling f v >>= showPercentBar v - -showLogVBar :: Float -> Float -> Monitor String -showLogVBar f v = logScaling f v >>= showVerticalBar v - -showLogIconPattern :: Maybe IconPattern -> Float -> Float -> Monitor String -showLogIconPattern str f v = logScaling f v >>= showIconPattern str diff --git a/src/Xmobar/Plugins/Monitors/CoreCommon.hs b/src/Xmobar/Plugins/Monitors/CoreCommon.hs deleted file mode 100644 index a84198e..0000000 --- a/src/Xmobar/Plugins/Monitors/CoreCommon.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE CPP, PatternGuards #-} - ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CoreCommon --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek <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 deleted file mode 100644 index 48fe428..0000000 --- a/src/Xmobar/Plugins/Monitors/CoreTemp.hs +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CoreTemp --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> --- Stability : unstable --- Portability : unportable --- --- A core temperature monitor for Xmobar --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index 6befe7d..0000000 --- a/src/Xmobar/Plugins/Monitors/Cpu.hs +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Cpu --- Copyright : (c) 2011, 2017 Jose Antonio Ortega Ruiz --- (c) 2007-2010 Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <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 deleted file mode 100644 index 1afedfa..0000000 --- a/src/Xmobar/Plugins/Monitors/CpuFreq.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.CpuFreq --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek <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 deleted file mode 100644 index aedad75..0000000 --- a/src/Xmobar/Plugins/Monitors/Disk.hs +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Disk --- Copyright : (c) 2010, 2011, 2012, 2014 Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Disk usage and throughput monitors for Xmobar --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where - -import Xmobar.Plugins.Monitors.Common -import Xmobar.StatFS - -import Data.IORef (IORef, newIORef, readIORef, writeIORef) - -import Control.Exception (SomeException, handle) -import Control.Monad (zipWithM) -import qualified Data.ByteString.Lazy.Char8 as B -import Data.List (isPrefixOf, find) -import Data.Maybe (catMaybes) -import System.Directory (canonicalizePath, doesFileExist) -import System.Console.GetOpt - -data DiskIOOpts = DiskIOOpts - { totalIconPattern :: Maybe IconPattern - , writeIconPattern :: Maybe IconPattern - , readIconPattern :: Maybe IconPattern - } - -parseDiskIOOpts :: [String] -> IO DiskIOOpts -parseDiskIOOpts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs - where defaultOpts = DiskIOOpts - { totalIconPattern = Nothing - , writeIconPattern = Nothing - , readIconPattern = Nothing - } - options = - [ Option "" ["total-icon-pattern"] (ReqArg (\x o -> - o { totalIconPattern = Just $ parseIconPattern x}) "") "" - , Option "" ["write-icon-pattern"] (ReqArg (\x o -> - o { writeIconPattern = Just $ parseIconPattern x}) "") "" - , Option "" ["read-icon-pattern"] (ReqArg (\x o -> - o { readIconPattern = Just $ parseIconPattern x}) "") "" - ] - -diskIOConfig :: IO MConfig -diskIOConfig = mkMConfig "" ["total", "read", "write" - ,"totalbar", "readbar", "writebar" - ,"totalvbar", "readvbar", "writevbar" - ,"totalipat", "readipat", "writeipat" - ] - -data DiskUOpts = DiskUOpts - { freeIconPattern :: Maybe IconPattern - , usedIconPattern :: Maybe IconPattern - } - -parseDiskUOpts :: [String] -> IO DiskUOpts -parseDiskUOpts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs - where defaultOpts = DiskUOpts - { freeIconPattern = Nothing - , usedIconPattern = Nothing - } - options = - [ Option "" ["free-icon-pattern"] (ReqArg (\x o -> - o { freeIconPattern = Just $ parseIconPattern x}) "") "" - , Option "" ["used-icon-pattern"] (ReqArg (\x o -> - o { usedIconPattern = Just $ parseIconPattern x}) "") "" - ] - -diskUConfig :: IO MConfig -diskUConfig = mkMConfig "" - [ "size", "free", "used", "freep", "usedp" - , "freebar", "freevbar", "freeipat" - , "usedbar", "usedvbar", "usedipat" - ] - -type DevName = String -type Path = String -type DevDataRef = IORef [(DevName, [Float])] - -mountedDevices :: [String] -> IO [(DevName, Path)] -mountedDevices req = do - s <- B.readFile "/etc/mtab" - parse `fmap` mapM mbcanon (devs s) - where - mbcanon (d, p) = doesFileExist d >>= \e -> - if e - then Just `fmap` canon (d,p) - else return Nothing - canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} - devs = filter isDev . map (firstTwo . B.words) . B.lines - parse = map undev . filter isReq . catMaybes - firstTwo (a:b:_) = (B.unpack a, B.unpack b) - firstTwo _ = ("", "") - isDev (d, _) = "/dev/" `isPrefixOf` d - isReq (d, p) = p `elem` req || drop 5 d `elem` req - undev (d, f) = (drop 5 d, f) - -diskDevices :: [String] -> IO [(DevName, Path)] -diskDevices req = do - s <- B.readFile "/proc/diskstats" - parse `fmap` mapM canon (devs s) - where - canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} - devs = map (third . B.words) . B.lines - parse = map undev . filter isReq - third (_:_:c:_) = ("/dev/" ++ B.unpack c, B.unpack c) - third _ = ("", "") - isReq (d, p) = p `elem` req || drop 5 d `elem` req - undev (d, f) = (drop 5 d, f) - -mountedOrDiskDevices :: [String] -> IO [(DevName, Path)] -mountedOrDiskDevices req = do - mnt <- mountedDevices req - case mnt of - [] -> diskDevices req - other -> return other - -diskData :: IO [(DevName, [Float])] -diskData = do - s <- B.readFile "/proc/diskstats" - let extract ws = (head ws, map read (tail ws)) - return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s) - -mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])] -mountedData dref devs = do - dt <- readIORef dref - dt' <- diskData - writeIORef dref dt' - return $ map (parseDev (zipWith diff dt' dt)) devs - where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys) - -parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float]) -parseDev dat dev = - case find ((==dev) . fst) dat of - Nothing -> (dev, [0, 0, 0]) - Just (_, xs) -> - let rSp = speed (xs !! 2) (xs !! 3) - wSp = speed (xs !! 6) (xs !! 7) - sp = speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7) - speed x t = if t == 0 then 0 else 500 * x / t - dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0] - in (dev, dat') - -speedToStr :: Float -> String -speedToStr = showWithUnits 2 1 - -sizeToStr :: Integer -> String -sizeToStr = showWithUnits 3 0 . fromIntegral - -findTempl :: DevName -> Path -> [(String, String)] -> String -findTempl dev path disks = - case find devOrPath disks of - Just (_, t) -> t - Nothing -> "" - where devOrPath (d, _) = d == dev || d == path - -devTemplates :: [(String, String)] - -> [(DevName, Path)] - -> [(DevName, [Float])] - -> [(String, [Float])] -devTemplates disks mounted dat = - map (\(d, p) -> (findTempl d p disks, findData d)) mounted - where findData dev = case find ((==dev) . fst) dat of - Nothing -> [0, 0, 0] - Just (_, xs) -> xs - -runDiskIO' :: DiskIOOpts -> (String, [Float]) -> Monitor String -runDiskIO' opts (tmp, xs) = do - s <- mapM (showWithColors speedToStr) xs - b <- mapM (showLogBar 0.8) xs - vb <- mapM (showLogVBar 0.8) xs - ipat <- mapM (\(f,v) -> showLogIconPattern (f opts) 0.8 v) - $ zip [totalIconPattern, readIconPattern, writeIconPattern] xs - setConfigValue tmp template - parseTemplate $ s ++ b ++ vb ++ ipat - -runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String -runDiskIO dref disks argv = do - opts <- io $ parseDiskIOOpts argv - dev <- io $ mountedOrDiskDevices (map fst disks) - dat <- io $ mountedData dref (map fst dev) - strs <- mapM (runDiskIO' opts) $ devTemplates disks dev dat - return $ unwords strs - -startDiskIO :: [(String, String)] -> - [String] -> Int -> (String -> IO ()) -> IO () -startDiskIO disks args rate cb = do - dev <- mountedOrDiskDevices (map fst disks) - dref <- newIORef (map (\d -> (fst d, repeat 0)) dev) - _ <- mountedData dref (map fst dev) - runM args diskIOConfig (runDiskIO dref disks) rate cb - -fsStats :: String -> IO [Integer] -fsStats path = do - stats <- getFileSystemStats path - case stats of - Nothing -> return [0, 0, 0] - Just f -> let tot = fsStatByteCount f - free = fsStatBytesAvailable f - used = fsStatBytesUsed f - in return [tot, free, used] - -runDiskU' :: DiskUOpts -> String -> String -> Monitor String -runDiskU' opts tmp path = do - setConfigValue tmp template - [total, free, diff] <- io (handle ign $ fsStats path) - let strs = map sizeToStr [free, diff] - freep = if total > 0 then free * 100 `div` total else 0 - fr = fromIntegral freep / 100 - s <- zipWithM showWithColors' strs [freep, 100 - freep] - sp <- showPercentsWithColors [fr, 1 - fr] - fb <- showPercentBar (fromIntegral freep) fr - fvb <- showVerticalBar (fromIntegral freep) fr - fipat <- showIconPattern (freeIconPattern opts) fr - ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr) - uvb <- showVerticalBar (fromIntegral $ 100 - freep) (1 - fr) - uipat <- showIconPattern (usedIconPattern opts) (1 - fr) - parseTemplate $ [sizeToStr total] ++ s ++ sp ++ [fb,fvb,fipat,ub,uvb,uipat] - where ign = const (return [0, 0, 0]) :: SomeException -> IO [Integer] - - -runDiskU :: [(String, String)] -> [String] -> Monitor String -runDiskU disks argv = do - devs <- io $ mountedDevices (map fst disks) - opts <- io $ parseDiskUOpts argv - strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs - return $ unwords strs diff --git a/src/Xmobar/Plugins/Monitors/MPD.hs b/src/Xmobar/Plugins/Monitors/MPD.hs deleted file mode 100644 index 9525254..0000000 --- a/src/Xmobar/Plugins/Monitors/MPD.hs +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.MPD --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz <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 deleted file mode 100644 index d69921b..0000000 --- a/src/Xmobar/Plugins/Monitors/Mem.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Mem --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <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 deleted file mode 100644 index 3556649..0000000 --- a/src/Xmobar/Plugins/Monitors/Mpris.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - ----------------------------------------------------------------------------- --- | --- Module : Plugins.Monitors.Mpris --- Copyright : (c) Artem Tarasov --- License : BSD-style (see LICENSE) --- --- Maintainer : Artem Tarasov <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 deleted file mode 100644 index 3db3b5f..0000000 --- a/src/Xmobar/Plugins/Monitors/MultiCpu.hs +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.MultiCpu --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A multi-cpu monitor for Xmobar --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index 81a5f6b..0000000 --- a/src/Xmobar/Plugins/Monitors/Net.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Net --- Copyright : (c) 2011, 2012, 2013, 2014, 2017 Jose Antonio Ortega Ruiz --- (c) 2007-2010 Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A net device monitor for Xmobar --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index fcaab84..0000000 --- a/src/Xmobar/Plugins/Monitors/Swap.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Swap --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A swap usage monitor for Xmobar --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index 320ae17..0000000 --- a/src/Xmobar/Plugins/Monitors/Thermal.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Thermal --- Copyright : (c) Juraj Hercek --- License : BSD-style (see LICENSE) --- --- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> --- Stability : unstable --- Portability : unportable --- --- A thermal monitor for Xmobar --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index bc46b59..0000000 --- a/src/Xmobar/Plugins/Monitors/ThermalZone.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module : Plugins.Monitors.ThermalZone --- Copyright : (c) 2011, 2013 Jose Antonio Ortega Ruiz --- License : BSD3-style (see LICENSE) --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : portable --- Created : Fri Feb 25, 2011 03:18 --- --- --- A thermal zone plugin based on the sysfs linux interface. --- See http://kernel.org/doc/Documentation/thermal/sysfs-api.txt --- ------------------------------------------------------------------------------- - -module 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 deleted file mode 100644 index d6df249..0000000 --- a/src/Xmobar/Plugins/Monitors/Top.hs +++ /dev/null @@ -1,195 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index 079177f..0000000 --- a/src/Xmobar/Plugins/Monitors/UVMeter.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.UVMeter --- Copyright : (c) Róman Joost --- License : BSD-style (see LICENSE) --- --- Maintainer : Róman Joost --- Stability : unstable --- Portability : unportable --- --- An australian uv monitor for Xmobar --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index 235fc85..0000000 --- a/src/Xmobar/Plugins/Monitors/Uptime.hs +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module : Plugins.Monitors.Uptime --- Copyright : (c) 2010 Jose Antonio Ortega Ruiz --- License : BSD3-style (see LICENSE) --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- Created: Sun Dec 12, 2010 20:26 --- --- --- Uptime --- ------------------------------------------------------------------------------- - - -module 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 deleted file mode 100644 index 1d3281c..0000000 --- a/src/Xmobar/Plugins/Monitors/Volume.hs +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 deleted file mode 100644 index cb5bf07..0000000 --- a/src/Xmobar/Plugins/Monitors/Weather.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Weather --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A weather monitor for Xmobar --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index 545f6bc..0000000 --- a/src/Xmobar/Plugins/Monitors/Wireless.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Wireless --- Copyright : (c) Jose Antonio Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose Antonio Ortega Ruiz --- Stability : unstable --- Portability : unportable --- --- A monitor reporting ESSID and link quality for wireless interfaces --- ------------------------------------------------------------------------------ - -module 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 deleted file mode 100644 index 7166163..0000000 --- a/src/Xmobar/Plugins/PipeReader.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.PipeReader --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from named pipes --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.PipeReader where - -import System.IO -import Xmobar.Plugins -import Xmobar.Environment -import System.Posix.Files -import Control.Concurrent(threadDelay) -import Control.Exception -import Control.Monad(forever, unless) -import Control.Applicative ((<$>)) - -data PipeReader = PipeReader String String - deriving (Read, Show) - -instance Exec PipeReader where - alias (PipeReader _ a) = a - start (PipeReader p _) cb = do - (def, pipe) <- split ':' <$> expandEnv p - unless (null def) (cb def) - checkPipe pipe - h <- openFile pipe ReadWriteMode - forever (hGetLineSafe h >>= cb) - where - split c xs | c `elem` xs = let (pre, post) = span (c /=) xs - in (pre, dropWhile (c ==) post) - | otherwise = ([], xs) - -checkPipe :: FilePath -> IO () -checkPipe file = - handle (\(SomeException _) -> waitForPipe) $ do - status <- getFileStatus file - unless (isNamedPipe status) waitForPipe - where waitForPipe = threadDelay 1000000 >> checkPipe file diff --git a/src/Xmobar/Plugins/StdinReader.hs b/src/Xmobar/Plugins/StdinReader.hs deleted file mode 100644 index 372e4f9..0000000 --- a/src/Xmobar/Plugins/StdinReader.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.StdinReader --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A plugin for reading from `stdin`. --- --- Exports: --- - `StdinReader` to safely display stdin content (striping actions). --- - `UnsafeStdinReader` to display stdin content as-is. --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.StdinReader (StdinReader(..)) where - -import Prelude -import System.Posix.Process -import System.Exit -import System.IO -import Control.Exception (SomeException(..), handle) -import Xmobar.Plugins -import Xmobar.Actions (stripActions) - -data StdinReader = StdinReader | UnsafeStdinReader - deriving (Read, Show) - -instance Exec StdinReader where - start stdinReader cb = do - s <- handle (\(SomeException e) -> do hPrint stderr e; return "") - (hGetLineSafe stdin) - cb $ escape stdinReader s - eof <- isEOF - if eof - then exitImmediately ExitSuccess - else start stdinReader cb - -escape :: StdinReader -> String -> String -escape StdinReader = stripActions -escape UnsafeStdinReader = id diff --git a/src/Xmobar/Plugins/Utils.hs b/src/Xmobar/Plugins/Utils.hs deleted file mode 100644 index 6546c15..0000000 --- a/src/Xmobar/Plugins/Utils.hs +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Plugins.Utils --- Copyright: (c) 2010 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: Jose A Ortega Ruiz <jao@gnu.org> --- Stability: unstable --- Portability: unportable --- Created: Sat Dec 11, 2010 20:55 --- --- --- Miscellaneous utility functions --- ------------------------------------------------------------------------------- - - -module Xmobar.Plugins.Utils (expandHome, changeLoop, safeHead) where - -import Control.Monad -import Control.Concurrent.STM - -import System.Environment -import System.FilePath - - -expandHome :: FilePath -> IO FilePath -expandHome ('~':'/':path) = fmap (</> path) (getEnv "HOME") -expandHome p = return p - -changeLoop :: Eq a => STM a -> (a -> IO ()) -> IO () -changeLoop s f = atomically s >>= go - where - go old = do - f old - go =<< atomically (do - new <- s - guard (new /= old) - return new) - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x diff --git a/src/Xmobar/Plugins/XMonadLog.hs b/src/Xmobar/Plugins/XMonadLog.hs deleted file mode 100644 index 6bbba59..0000000 --- a/src/Xmobar/Plugins/XMonadLog.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Plugins.StdinReader --- Copyright : (c) Spencer Janssen --- License : BSD-style (see LICENSE) --- --- Maintainer : Spencer Janssen <spencerjanssen@gmail.com> --- Stability : unstable --- Portability : unportable --- --- A plugin to display information from _XMONAD_LOG, specified at --- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.XMonadLog (XMonadLog(..)) where - -import Control.Monad -import Graphics.X11 -import Graphics.X11.Xlib.Extras -import Xmobar.Plugins -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar) -import Xmobar.XUtil (nextEvent') -import Xmobar.Actions (stripActions) - -data XMonadLog = XMonadLog - | UnsafeXMonadLog - | XPropertyLog String - | UnsafeXPropertyLog String - | NamedXPropertyLog String String - | UnsafeNamedXPropertyLog String String - deriving (Read, Show) - -instance Exec XMonadLog where - alias XMonadLog = "XMonadLog" - alias UnsafeXMonadLog = "UnsafeXMonadLog" - alias (XPropertyLog atom) = atom - alias (NamedXPropertyLog _ name) = name - alias (UnsafeXPropertyLog atom) = atom - alias (UnsafeNamedXPropertyLog _ name) = name - - start x cb = do - let atom = case x of - XMonadLog -> "_XMONAD_LOG" - UnsafeXMonadLog -> "_XMONAD_LOG" - XPropertyLog a -> a - UnsafeXPropertyLog a -> a - NamedXPropertyLog a _ -> a - UnsafeNamedXPropertyLog a _ -> a - sanitize = case x of - UnsafeXMonadLog -> id - UnsafeXPropertyLog _ -> id - UnsafeNamedXPropertyLog _ _ -> id - _ -> stripActions - - d <- openDisplay "" - xlog <- internAtom d atom False - - root <- rootWindow d (defaultScreen d) - selectInput d root propertyChangeMask - - let update = do - mwp <- getWindowProperty8 d xlog root - maybe (return ()) (cb . sanitize . decodeCChar) mwp - - update - - allocaXEvent $ \ep -> forever $ do - nextEvent' d ep - e <- getEvent ep - case e of - PropertyEvent { ev_atom = a } | a == xlog -> update - _ -> return () - - return () - -decodeCChar :: [CChar] -> String -#ifdef UTF8 -#undef UTF8 -decodeCChar = UTF8.decode . map fromIntegral -#define UTF8 -#else -decodeCChar = map (toEnum . fromIntegral) -#endif |