diff options
Diffstat (limited to 'src/lib/Xmobar')
62 files changed, 0 insertions, 7623 deletions
diff --git a/src/lib/Xmobar/Actions.hs b/src/lib/Xmobar/Actions.hs deleted file mode 100644 index 7901845..0000000 --- a/src/lib/Xmobar/Actions.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Actions --- Copyright : (c) Alexander Polakov --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.Actions (Action(..), runAction, stripActions) where - -import System.Process (system) -import Control.Monad (void) -import Text.Regex (Regex, subRegex, mkRegex, matchRegex) -import Graphics.X11.Types (Button) - -data Action = Spawn [Button] String - deriving (Eq) - -runAction :: Action -> IO () -runAction (Spawn _ s) = void $ system (s ++ "&") - -stripActions :: String -> String -stripActions s = case matchRegex actionRegex s of - Nothing -> s - Just _ -> stripActions strippedOneLevel - where - strippedOneLevel = subRegex actionRegex s "[action=\\1\\2]\\3[/action]" - -actionRegex :: Regex -actionRegex = mkRegex "<action=`?([^>`]*)`?( +button=[12345]+)?>(.+)</action>" diff --git a/src/lib/Xmobar/Config.hs b/src/lib/Xmobar/Config.hs deleted file mode 100644 index a07af9e..0000000 --- a/src/lib/Xmobar/Config.hs +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Config --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- The configuration module of Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Xmobar.Config - ( -- * Configuration - -- $config - Config (..) - , XPosition (..), Align (..), Border(..) - , defaultConfig - , getXdgConfigFile - ) where - -import Xmobar.Plugins.Date -import Xmobar.Plugins.StdinReader - -import System.Environment -import System.Directory (getHomeDirectory) -import System.FilePath ((</>)) - -import Xmobar.Run.Runnable (Runnable(..)) - --- $config --- Configuration data type and default configuration - --- | The configuration data type -data Config = - Config { font :: String -- ^ Font - , additionalFonts :: [String] -- ^ List of alternative fonts - , wmClass :: String -- ^ X11 WM_CLASS property value - , wmName :: String -- ^ X11 WM_NAME property value - , bgColor :: String -- ^ Backgroud color - , fgColor :: String -- ^ Default font color - , position :: XPosition -- ^ Top Bottom or Static - , textOffset :: Int -- ^ Offset from top of window for text - , textOffsets :: [Int] -- ^ List of offsets for additionalFonts - , iconOffset :: Int -- ^ Offset from top of window for icons - , border :: Border -- ^ NoBorder TopB BottomB or FullB - , borderColor :: String -- ^ Border color - , borderWidth :: Int -- ^ Border width - , alpha :: Int -- ^ Transparency from 0 (transparent) - -- to 255 (opaque) - , hideOnStart :: Bool -- ^ Hide (Unmap) the window on - -- initialization - , allDesktops :: Bool -- ^ Tell the WM to map to all desktops - , overrideRedirect :: Bool -- ^ Needed for dock behaviour in some - -- non-tiling WMs - , pickBroadest :: Bool -- ^ Use the broadest display - -- instead of the first one by - -- default - , lowerOnStart :: Bool -- ^ lower to the bottom of the - -- window stack on initialization - , persistent :: Bool -- ^ Whether automatic hiding should - -- be enabled or disabled - , iconRoot :: FilePath -- ^ Root folder for icons - , commands :: [Runnable] -- ^ For setting the command, - -- the command arguments - -- and refresh rate for the programs - -- to run (optional) - , sepChar :: String -- ^ The character to be used for indicating - -- commands in the output template - -- (default '%') - , alignSep :: String -- ^ Separators for left, center and - -- right text alignment - , template :: String -- ^ The output template - } deriving (Read) - -data XPosition = Top - | TopW Align Int - | TopSize Align Int Int - | TopP Int Int - | Bottom - | BottomP Int Int - | BottomW Align Int - | BottomSize Align Int Int - | Static {xpos, ypos, width, height :: Int} - | OnScreen Int XPosition - deriving ( Read, Eq ) - -data Align = L | R | C deriving ( Read, Eq ) - -data Border = NoBorder - | TopB - | BottomB - | FullB - | TopBM Int - | BottomBM Int - | FullBM Int - deriving ( Read, Eq ) - --- | The default configuration values -defaultConfig :: Config -defaultConfig = - Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , additionalFonts = [] - , wmClass = "xmobar" - , wmName = "xmobar" - , bgColor = "#000000" - , fgColor = "#BFBFBF" - , alpha = 255 - , position = Top - , border = NoBorder - , borderColor = "#BFBFBF" - , borderWidth = 1 - , textOffset = -1 - , iconOffset = -1 - , textOffsets = [] - , hideOnStart = False - , lowerOnStart = True - , persistent = False - , allDesktops = True - , overrideRedirect = True - , pickBroadest = False - , iconRoot = "." - , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 - , Run StdinReader] - , sepChar = "%" - , alignSep = "}{" - , template = "%StdinReader% }{ " ++ - "<fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>" - } - -xdgConfigDir :: IO String -xdgConfigDir = do env <- getEnvironment - case lookup "XDG_CONFIG_HOME" env of - Just val -> return val - Nothing -> fmap (</> ".config") getHomeDirectory - -xmobarConfigDir :: IO FilePath -xmobarConfigDir = fmap (</> "xmobar") xdgConfigDir - -getXdgConfigFile :: IO FilePath -getXdgConfigFile = fmap (</> "xmobarrc") xmobarConfigDir diff --git a/src/lib/Xmobar/Plugins/BufferedPipeReader.hs b/src/lib/Xmobar/Plugins/BufferedPipeReader.hs deleted file mode 100644 index 65ecea2..0000000 --- a/src/lib/Xmobar/Plugins/BufferedPipeReader.hs +++ /dev/null @@ -1,88 +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(BufferedPipeReader(..)) where - -import Control.Monad(forM_, when, void) -import Control.Concurrent -import Control.Concurrent.STM -import System.IO -import System.IO.Unsafe(unsafePerformIO) - -import Xmobar.Utils(hGetLineSafe) -import Xmobar.Run.Commands -import Xmobar.System.Signal -import Xmobar.System.Environment - -data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] - deriving (Read, Show) - -{-# NOINLINE signal #-} -signal :: MVar SignalType -signal = unsafePerformIO newEmptyMVar - -instance Exec BufferedPipeReader where - alias ( BufferedPipeReader a _ ) = a - - trigger br@( BufferedPipeReader _ _ ) sh = - takeMVar signal >>= sh . Just >> trigger br sh - - start ( BufferedPipeReader _ ps ) cb = do - - (chan, str, rst) <- initV - forM_ ps $ \p -> forkIO $ reader p chan - writer chan str rst - - where - initV :: IO (TChan (Int, Bool, String), TVar (Maybe String), TVar Bool) - initV = atomically $ do - tc <- newTChan - ts <- newTVar Nothing - tb <- newTVar False - return (tc, ts, tb) - - reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () - reader p@(to, tg, fp) tc = do - fp' <- expandEnv fp - openFile fp' ReadWriteMode >>= hGetLineSafe >>= \dt -> - atomically $ writeTChan tc (to, tg, dt) - reader p tc - - writer :: TChan (Int, Bool, String) - -> TVar (Maybe String) -> TVar Bool -> IO () - writer tc ts otb = do - (to, tg, dt, ntb) <- update - cb dt - when tg $ putMVar signal $ Reveal 0 - when (to /= 0) $ sfork $ reset to tg ts ntb - writer tc ts ntb - - where - sfork :: IO () -> IO () - sfork f = void (forkIO f) - - update :: IO (Int, Bool, String, TVar Bool) - update = atomically $ do - (to, tg, dt) <- readTChan tc - when (to == 0) $ writeTVar ts $ Just dt - writeTVar otb False - tb <- newTVar True - return (to, tg, dt, tb) - - reset :: Int -> Bool -> TVar (Maybe String) -> TVar Bool -> IO () - reset to tg ts tb = do - threadDelay ( to * 100 * 1000 ) - readTVarIO tb >>= \b -> when b $ do - when tg $ putMVar signal $ Hide 0 - readTVarIO ts >>= maybe (return ()) cb diff --git a/src/lib/Xmobar/Plugins/CommandReader.hs b/src/lib/Xmobar/Plugins/CommandReader.hs deleted file mode 100644 index 69c8e0c..0000000 --- a/src/lib/Xmobar/Plugins/CommandReader.hs +++ /dev/null @@ -1,40 +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(CommandReader(..)) where - -import System.IO -import Xmobar.Run.Commands -import Xmobar.Utils (hGetLineSafe) -import System.Process(runInteractiveCommand, getProcessExitCode) - -data CommandReader = CommandReader String String - deriving (Read, Show) - -instance Exec CommandReader where - alias (CommandReader _ a) = a - start (CommandReader p _) cb = do - (hstdin, hstdout, hstderr, ph) <- runInteractiveCommand p - hClose hstdin - hClose hstderr - hSetBinaryMode hstdout False - hSetBuffering hstdout LineBuffering - forever ph (hGetLineSafe hstdout >>= cb) - where forever ph a = - do a - ec <- getProcessExitCode ph - case ec of - Nothing -> forever ph a - Just _ -> cb "EXITED" diff --git a/src/lib/Xmobar/Plugins/Date.hs b/src/lib/Xmobar/Plugins/Date.hs deleted file mode 100644 index 62a4ee7..0000000 --- a/src/lib/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.Run.Commands - -#if ! MIN_VERSION_time(1,5,0) -import System.Locale -#endif -import Data.Time - -data Date = Date String String Int - deriving (Read, Show) - -instance Exec Date where - alias (Date _ a _) = a - run (Date f _ _) = date f - rate (Date _ _ r) = r - -date :: String -> IO String -date format = fmap (formatTime defaultTimeLocale format) getZonedTime diff --git a/src/lib/Xmobar/Plugins/DateZone.hs b/src/lib/Xmobar/Plugins/DateZone.hs deleted file mode 100644 index 7215713..0000000 --- a/src/lib/Xmobar/Plugins/DateZone.hs +++ /dev/null @@ -1,86 +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.Run.Commands -import Xmobar.Utils(tenthSeconds) - -#ifdef DATEZONE -import Control.Concurrent.STM - -import System.IO.Unsafe - -import Data.Time.Format -import Data.Time.LocalTime -import Data.Time.LocalTime.TimeZone.Olson -import Data.Time.LocalTime.TimeZone.Series - -import Xmobar.System.Localize - -#if ! MIN_VERSION_time(1,5,0) -import System.Locale (TimeLocale) -#endif -#else -import System.IO -import Xmobar.Plugins.Date -#endif - - - -data DateZone = DateZone String String String String Int - deriving (Read, Show) - -instance Exec DateZone where - alias (DateZone _ _ _ a _) = a -#ifndef DATEZONE - start (DateZone f _ _ a r) cb = do - hPutStrLn stderr $ "Warning: DateZone plugin needs -fwith_datezone."++ - " Using Date plugin instead." - start (Date f a r) cb -#else - start (DateZone f l z _ r) cb = do - lock <- atomically $ takeTMVar localeLock - setupTimeLocale l - locale <- getTimeLocale - atomically $ putTMVar localeLock lock - if z /= "" then do - timeZone <- getTimeZoneSeriesFromOlsonFile ("/usr/share/zoneinfo/" ++ z) - go (dateZone f locale timeZone) - else - go (date f locale) - - where go func = func >>= cb >> tenthSeconds r >> go func - -{-# NOINLINE localeLock #-} --- ensures that only one plugin instance sets the locale -localeLock :: TMVar Bool -localeLock = unsafePerformIO (newTMVarIO False) - -date :: String -> TimeLocale -> IO String -date format loc = getZonedTime >>= return . formatTime loc format - -dateZone :: String -> TimeLocale -> TimeZoneSeries -> IO String -dateZone format loc timeZone = getZonedTime >>= return . formatTime loc format . utcToLocalTime' timeZone . zonedTimeToUTC --- zonedTime <- getZonedTime --- return $ formatTime loc format $ utcToLocalTime' timeZone $ zonedTimeToUTC zonedTime -#endif diff --git a/src/lib/Xmobar/Plugins/EWMH.hs b/src/lib/Xmobar/Plugins/EWMH.hs deleted file mode 100644 index 4a443d6..0000000 --- a/src/lib/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.Run.Commands -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar, CLong) -import Xmobar.Utils (nextEvent') - -import Data.List (intersperse, intercalate) - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - - -data EWMH = EWMH | EWMHFMT Component deriving (Read, Show) - -instance Exec EWMH where - alias EWMH = "EWMH" - - start ew cb = allocaXEvent $ \ep -> execM $ do - d <- asks display - r <- asks root - - liftIO xSetErrorHandler - - liftIO $ selectInput d r propertyChangeMask - handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers - mapM_ ((=<< asks root) . snd) handlers' - - forever $ do - liftIO . cb . fmtOf ew =<< get - liftIO $ nextEvent' d ep - e <- liftIO $ getEvent ep - case e of - PropertyEvent { ev_atom = a, ev_window = w } -> - case lookup a handlers' of - Just f -> f w - _ -> return () - _ -> return () - - return () - -defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty] - , Layout - , Color "#00ee00" "" :$ Short 120 :$ WindowName] - -fmtOf EWMH = flip fmt defaultPP -fmtOf (EWMHFMT f) = flip fmt f - -sep :: [a] -> [[a]] -> [a] -sep x xs = intercalate x $ filter (not . null) xs - -fmt :: EwmhState -> Component -> String -fmt e (Text s) = s -fmt e (l :+ r) = fmt e l ++ fmt e r -fmt e (m :$ r) = modifier m $ fmt e r -fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs -fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e) -fmt e Layout = layout e -fmt e (Workspaces opts) = sep " " - [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as] - | (n, as) <- attrs] - where - stats i = [ (Current, i == currentDesktop e) - , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e) - -- TODO for visible , (Visibl - ] - attrs :: [(String, [WsType])] - attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)] - nonEmptys = Set.unions . map desktops . Map.elems $ clients e - -modifier :: Modifier -> String -> String -modifier Hide = const "" -modifier (Color fg bg) = \x -> concat ["<fc=", fg, if null bg then "" else "," ++ bg - , ">", x, "</fc>"] -modifier (Short n) = take n -modifier (Wrap l r) = \x -> l ++ x ++ r - -data Component = Text String - | Component :+ Component - | Modifier :$ Component - | Sep Component [Component] - | WindowName - | Layout - | Workspaces [WsOpt] - deriving (Read, Show) - -infixr 0 :$ -infixr 5 :+ - -data Modifier = Hide - | Color String String - | Short Int - | Wrap String String - deriving (Read, Show) - -data WsOpt = Modifier :% WsType - | WSep Component - deriving (Read, Show) -infixr 0 :% - -data WsType = Current | Empty | Visible - deriving (Read, Show, Eq) - -data EwmhConf = C { root :: Window - , display :: Display } - -data EwmhState = S { currentDesktop :: CLong - , activeWindow :: Window - , desktopNames :: [String] - , layout :: String - , clients :: Map Window Client } - deriving Show - -data Client = Cl { windowName :: String - , desktops :: Set CLong } - deriving Show - -getAtom :: String -> M Atom -getAtom s = do - d <- asks display - liftIO $ internAtom d s False - -windowProperty32 :: String -> Window -> M (Maybe [CLong]) -windowProperty32 s w = do - C {display} <- ask - a <- getAtom s - liftIO $ getWindowProperty32 display a w - -windowProperty8 :: String -> Window -> M (Maybe [CChar]) -windowProperty8 s w = do - C {display} <- ask - a <- getAtom s - liftIO $ getWindowProperty8 display a w - -initialState :: EwmhState -initialState = S 0 0 [] [] Map.empty - -initialClient :: Client -initialClient = Cl "" Set.empty - -handlers, clientHandlers :: [(String, Updater)] -handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop) - , ("_NET_DESKTOP_NAMES", updateDesktopNames ) - , ("_NET_ACTIVE_WINDOW", updateActiveWindow) - , ("_NET_CLIENT_LIST", updateClientList) - ] ++ clientHandlers - -clientHandlers = [ ("_NET_WM_NAME", updateName) - , ("_NET_WM_DESKTOP", updateDesktop) ] - -newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a) - deriving (Monad, Functor, Applicative, MonadIO, MonadReader EwmhConf, MonadState EwmhState) - -execM :: M a -> IO a -execM (M m) = do - d <- openDisplay "" - r <- rootWindow d (defaultScreen d) - let conf = C r d - evalStateT (runReaderT m (C r d)) initialState - -type Updater = Window -> M () - -updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater -updateCurrentDesktop _ = do - C {root} <- ask - mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root - case mwp of - Just [x] -> modify (\s -> s { currentDesktop = x }) - _ -> return () - -updateActiveWindow _ = do - C {root} <- ask - mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root - case mwp of - Just [x] -> modify (\s -> s { activeWindow = fromIntegral x }) - _ -> return () - -updateDesktopNames _ = do - C {root} <- ask - mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root - case mwp of - Just xs -> modify (\s -> s { desktopNames = parse xs }) - _ -> return () - where - dropNull ('\0':xs) = xs - dropNull xs = xs - - split [] = [] - split xs = case span (/= '\0') xs of - (x, ys) -> x : split (dropNull ys) - parse = split . decodeCChar - -updateClientList _ = do - C {root} <- ask - mwp <- windowProperty32 "_NET_CLIENT_LIST" root - case mwp of - Just xs -> do - cl <- gets clients - let cl' = Map.fromList $ map ((, initialClient) . fromIntegral) xs - dels = Map.difference cl cl' - new = Map.difference cl' cl - modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'}) - mapM_ (unmanage . fst) (Map.toList dels) - mapM_ (listen . fst) (Map.toList cl') - mapM_ (update . fst) (Map.toList new) - _ -> return () - where - unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0 - listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask - update w = mapM_ (($ w) . snd) clientHandlers - -modifyClient :: Window -> (Client -> Client) -> M () -modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s }) - where - f' Nothing = Just $ f initialClient - f' (Just x) = Just $ f x - -updateName w = do - mwp <- windowProperty8 "_NET_WM_NAME" w - case mwp of - Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs }) - _ -> return () - -updateDesktop w = do - mwp <- windowProperty32 "_NET_WM_DESKTOP" w - case mwp of - Just x -> modifyClient w (\c -> c { desktops = Set.fromList x }) - _ -> return () - -decodeCChar :: [CChar] -> String -#ifdef UTF8 -#undef UTF8 -decodeCChar = UTF8.decode . map fromIntegral -#define UTF8 -#else -decodeCChar = map (toEnum . fromIntegral) -#endif diff --git a/src/lib/Xmobar/Plugins/Kbd.hs b/src/lib/Xmobar/Plugins/Kbd.hs deleted file mode 100644 index f4dad36..0000000 --- a/src/lib/Xmobar/Plugins/Kbd.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Kbd --- Copyright : (c) Martin Perner --- License : BSD-style (see LICENSE) --- --- Maintainer : Martin Perner <martin@perner.cc> --- Stability : unstable --- Portability : unportable --- --- A keyboard layout indicator for Xmobar --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Kbd(Kbd(..)) where - -import Data.List (isPrefixOf, findIndex) -import Data.Maybe (fromJust) -import Control.Monad (forever) -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras - -import Xmobar.Run.Commands -import Xmobar.Utils (nextEvent') -import Xmobar.System.Kbd - - --- 'Bad' prefixes of layouts -noLaySymbols :: [String] -noLaySymbols = ["group", "inet", "ctr", "pc", "ctrl"] - - --- splits the layout string into the actual layouts -splitLayout :: String -> [String] -splitLayout s = splitLayout' noLaySymbols $ split s '+' - -splitLayout' :: [String] -> [String] -> [String] --- end of recursion, remove empty strings -splitLayout' [] s = map (takeWhile (/= ':')) $ filter (not . null) s --- remove current string if it has a 'bad' prefix -splitLayout' bad s = - splitLayout' (tail bad) [x | x <- s, not $ isPrefixOf (head bad) x] - --- split String at each Char -split :: String -> Char -> [String] -split [] _ = [""] -split (c:cs) delim - | c == delim = "" : rest - | otherwise = (c : head rest) : tail rest - where - rest = split cs delim - --- replaces input string if on search list (exact match) with corresponding --- element on replacement list. --- --- if not found, return string unchanged -searchReplaceLayout :: KbdOpts -> String -> String -searchReplaceLayout opts s = let c = findIndex (\x -> fst x == s) opts in - case c of - Nothing -> s - x -> let i = fromJust x in snd $ opts!!i - --- returns the active layout -getKbdLay :: Display -> KbdOpts -> IO String -getKbdLay dpy opts = do - lay <- getLayoutStr dpy - curLay <- getKbdLayout dpy - return $ searchReplaceLayout opts $ splitLayout lay!!curLay - - - -newtype Kbd = Kbd [(String, String)] - deriving (Read, Show) - -instance Exec Kbd where - alias (Kbd _) = "kbd" - start (Kbd opts) cb = do - - dpy <- openDisplay "" - - -- initial set of layout - cb =<< getKbdLay dpy opts - - -- enable listing for - -- group changes - _ <- xkbSelectEventDetails dpy xkbUseCoreKbd xkbStateNotify xkbAllStateComponentsMask xkbGroupStateMask - -- layout/geometry changes - _ <- xkbSelectEvents dpy xkbUseCoreKbd xkbNewKeyboardNotifyMask xkbNewKeyboardNotifyMask - - allocaXEvent $ \e -> forever $ do - nextEvent' dpy e - _ <- getEvent e - cb =<< getKbdLay dpy opts - - closeDisplay dpy - return () diff --git a/src/lib/Xmobar/Plugins/Locks.hs b/src/lib/Xmobar/Plugins/Locks.hs deleted file mode 100644 index 19bce20..0000000 --- a/src/lib/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(Locks(..)) where - -import Graphics.X11 -import Data.List -import Data.Bits -import Control.Monad -import Graphics.X11.Xlib.Extras -import Xmobar.Run.Commands -import Xmobar.System.Kbd -import Xmobar.Utils (nextEvent') - -data Locks = Locks - deriving (Read, Show) - -locks :: [ ( KeySym, String )] -locks = [ ( xK_Caps_Lock, "CAPS" ) - , ( xK_Num_Lock, "NUM" ) - , ( xK_Scroll_Lock, "SCROLL" ) - ] - -run' :: Display -> Window -> IO String -run' d root = do - modMap <- getModifierMapping d - ( _, _, _, _, _, _, _, m ) <- queryPointer d root - - ls <- filterM ( \( ks, _ ) -> do - kc <- keysymToKeycode d ks - return $ case find (elem kc . snd) modMap of - Nothing -> False - Just ( i, _ ) -> testBit m (fromIntegral i) - ) locks - - return $ unwords $ map snd ls - -instance Exec Locks where - alias Locks = "locks" - start Locks cb = do - d <- openDisplay "" - root <- rootWindow d (defaultScreen d) - _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m - - allocaXEvent $ \ep -> forever $ do - cb =<< run' d root - nextEvent' d ep - getEvent ep - - closeDisplay d - return () - where - m = xkbAllStateComponentsMask diff --git a/src/lib/Xmobar/Plugins/MBox.hs b/src/lib/Xmobar/Plugins/MBox.hs deleted file mode 100644 index 4bd0ebd..0000000 --- a/src/lib/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.Run.Commands -#ifdef INOTIFY -import Xmobar.Utils (changeLoop, expandHome) - -import Control.Monad (when) -import Control.Concurrent.STM -import Control.Exception (SomeException (..), handle, evaluate) - -import System.Console.GetOpt -import System.Directory (doesFileExist) -import System.FilePath ((</>)) -import System.INotify (Event(..), EventVariety(..), initINotify, addWatch) - -import qualified Data.ByteString.Lazy.Char8 as B - -#if MIN_VERSION_hinotify(0,3,10) -import qualified Data.ByteString.Char8 as BS (ByteString, pack) -pack :: String -> BS.ByteString -pack = BS.pack -#else -pack :: String -> String -pack = id -#endif - -data Options = Options - { oAll :: Bool - , oUniq :: Bool - , oDir :: FilePath - , oPrefix :: String - , oSuffix :: String - } - -defaults :: Options -defaults = Options { - oAll = False, oUniq = False, oDir = "", oPrefix = "", oSuffix = "" - } - -options :: [OptDescr (Options -> Options)] -options = - [ Option "a" ["all"] (NoArg (\o -> o { oAll = True })) "" - , Option "u" [] (NoArg (\o -> o { oUniq = True })) "" - , Option "d" ["dir"] (ReqArg (\x o -> o { oDir = x }) "") "" - , Option "p" ["prefix"] (ReqArg (\x o -> o { oPrefix = x }) "") "" - , Option "s" ["suffix"] (ReqArg (\x o -> o { oSuffix = x }) "") "" - ] - -parseOptions :: [String] -> IO Options -parseOptions args = - case getOpt Permute options args of - (o, _, []) -> return $ foldr id defaults o - (_, _, errs) -> ioError . userError $ concat errs - -#else -import System.IO -#endif - --- | A list of display names, paths to mbox files and display colours, --- followed by a list of options. -data MBox = MBox [(String, FilePath, String)] [String] String - deriving (Read, Show) - -instance Exec MBox where - alias (MBox _ _ a) = a -#ifndef INOTIFY - start _ _ = - hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify" ++ - " but the MBox plugin requires it" -#else - start (MBox boxes args _) cb = do - opts <- parseOptions args - let showAll = oAll opts - prefix = oPrefix opts - suffix = oSuffix opts - uniq = oUniq opts - names = map (\(t, _, _) -> t) boxes - colors = map (\(_, _, c) -> c) boxes - extractPath (_, f, _) = expandHome $ oDir opts </> f - events = [CloseWrite] - - i <- initINotify - vs <- mapM (\b -> do - f <- extractPath b - exists <- doesFileExist f - n <- if exists then countMails f else return (-1) - v <- newTVarIO (f, n) - when exists $ - addWatch i events (pack f) (handleNotification v) >> return () - return v) - boxes - - changeLoop (mapM (fmap snd . readTVar) vs) $ \ns -> - let s = unwords [ showC uniq m n c | (m, n, c) <- zip3 names ns colors - , showAll || n > 0 ] - in cb (if null s then "" else prefix ++ s ++ suffix) - -showC :: Bool -> String -> Int -> String -> String -showC u m n c = - if c == "" then msg else "<fc=" ++ c ++ ">" ++ msg ++ "</fc>" - where msg = m ++ if not u || n > 1 then show n else "" - -countMails :: FilePath -> IO Int -countMails f = - handle (\(SomeException _) -> evaluate 0) - (do txt <- B.readFile f - evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt) - where from = B.pack "From " - -handleNotification :: TVar (FilePath, Int) -> Event -> IO () -handleNotification v _ = do - (p, _) <- atomically $ readTVar v - n <- countMails p - atomically $ writeTVar v (p, n) -#endif diff --git a/src/lib/Xmobar/Plugins/Mail.hs b/src/lib/Xmobar/Plugins/Mail.hs deleted file mode 100644 index d59e70d..0000000 --- a/src/lib/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(Mail(..)) where - -import Xmobar.Run.Commands -#ifdef INOTIFY -import Xmobar.Utils (expandHome, changeLoop) - -import Control.Monad -import Control.Concurrent.STM - -import System.Directory -import System.FilePath -import System.INotify - -import Data.List (isPrefixOf) -import Data.Set (Set) -import qualified Data.Set as S - -#if MIN_VERSION_hinotify(0,3,10) -import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack) -unpack :: BS.ByteString -> String -unpack = BS.unpack -pack :: String -> BS.ByteString -pack = BS.pack -#else -unpack :: String -> String -unpack = id -pack :: String -> String -pack = id -#endif -#else -import System.IO -#endif - - --- | A list of mail box names and paths to maildirs. -data Mail = Mail [(String, FilePath)] String - deriving (Read, Show) - -instance Exec Mail where - alias (Mail _ a) = a -#ifndef INOTIFY - start _ _ = - hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify," - ++ " but the Mail plugin requires it." -#else - start (Mail ms _) cb = do - vs <- mapM (const $ newTVarIO S.empty) ms - - let ts = map fst ms - rs = map ((</> "new") . snd) ms - ev = [Move, MoveIn, MoveOut, Create, Delete] - - ds <- mapM expandHome rs - i <- initINotify - zipWithM_ (\d v -> addWatch i ev d (handle v)) (map pack ds) vs - - forM_ (zip ds vs) $ \(d, v) -> do - s <- fmap (S.fromList . filter (not . isPrefixOf ".")) - $ getDirectoryContents d - atomically $ modifyTVar v (S.union s) - - changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns -> - cb . unwords $ [m ++ show n - | (m, n) <- zip ts ns - , n /= 0 ] - -handle :: TVar (Set String) -> Event -> IO () -handle v e = atomically $ modifyTVar v $ case e of - Created {} -> create - MovedIn {} -> create - Deleted {} -> delete - MovedOut {} -> delete - _ -> id - where - delete = S.delete ((unpack . filePath) e) - create = S.insert ((unpack . filePath) e) -#endif diff --git a/src/lib/Xmobar/Plugins/MarqueePipeReader.hs b/src/lib/Xmobar/Plugins/MarqueePipeReader.hs deleted file mode 100644 index a48e81c..0000000 --- a/src/lib/Xmobar/Plugins/MarqueePipeReader.hs +++ /dev/null @@ -1,71 +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.System.Environment -import Xmobar.Utils(tenthSeconds, hGetLineSafe) -import Xmobar.Run.Commands(Exec(alias, start)) -import System.Posix.Files (getFileStatus, isNamedPipe) -import Control.Concurrent(forkIO, threadDelay) -import Control.Concurrent.STM (TChan, atomically, writeTChan, tryReadTChan, newTChan) -import Control.Exception -import Control.Monad(forever, unless) -import Control.Applicative ((<$>)) - -type Length = Int -- length of the text to display -type Rate = Int -- delay in tenth seconds -type Separator = String -- if text wraps around, use separator - -data MarqueePipeReader = MarqueePipeReader String (Length, Rate, Separator) String - deriving (Read, Show) - -instance Exec MarqueePipeReader where - alias (MarqueePipeReader _ _ a) = a - start (MarqueePipeReader p (len, rate, sep) _) cb = do - (def, pipe) <- split ':' <$> expandEnv p - unless (null def) (cb def) - checkPipe pipe - h <- openFile pipe ReadWriteMode - line <- hGetLineSafe h - chan <- atomically newTChan - forkIO $ writer (toInfTxt line sep) sep len rate chan cb - forever $ pipeToChan h chan - where - split c xs | c `elem` xs = let (pre, post) = span (c /=) xs - in (pre, dropWhile (c ==) post) - | otherwise = ([], xs) - -pipeToChan :: Handle -> TChan String -> IO () -pipeToChan h chan = do - line <- hGetLineSafe h - atomically $ writeTChan chan line - -writer :: String -> Separator -> Length -> Rate -> TChan String -> (String -> IO ()) -> IO () -writer txt sep len rate chan cb = do - cb (take len txt) - mbnext <- atomically $ tryReadTChan chan - case mbnext of - Just new -> writer (toInfTxt new sep) sep len rate chan cb - Nothing -> tenthSeconds rate >> writer (drop 1 txt) sep len rate chan cb - -toInfTxt :: String -> String -> String -toInfTxt line sep = concat (repeat $ line ++ " " ++ sep ++ " ") - -checkPipe :: FilePath -> IO () -checkPipe file = handle (\(SomeException _) -> waitForPipe) $ do - status <- getFileStatus file - unless (isNamedPipe status) waitForPipe - where waitForPipe = threadDelay 1000 >> checkPipe file diff --git a/src/lib/Xmobar/Plugins/Monitors.hs b/src/lib/Xmobar/Plugins/Monitors.hs deleted file mode 100644 index fe909d8..0000000 --- a/src/lib/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.Run.Commands - -import Xmobar.Plugins.Monitors.Common (runM, runMD) -#ifdef WEATHER -import Xmobar.Plugins.Monitors.Weather -#endif -import Xmobar.Plugins.Monitors.Net -import Xmobar.Plugins.Monitors.Mem -import Xmobar.Plugins.Monitors.Swap -import Xmobar.Plugins.Monitors.Cpu -import Xmobar.Plugins.Monitors.MultiCpu -import Xmobar.Plugins.Monitors.Batt -import Xmobar.Plugins.Monitors.Bright -import Xmobar.Plugins.Monitors.Thermal -import Xmobar.Plugins.Monitors.ThermalZone -import Xmobar.Plugins.Monitors.CpuFreq -import Xmobar.Plugins.Monitors.CoreTemp -import Xmobar.Plugins.Monitors.Disk -import Xmobar.Plugins.Monitors.Top -import Xmobar.Plugins.Monitors.Uptime -import Xmobar.Plugins.Monitors.CatInt -#ifdef UVMETER -import Xmobar.Plugins.Monitors.UVMeter -#endif -#ifdef IWLIB -import Xmobar.Plugins.Monitors.Wireless -#endif -#ifdef LIBMPD -import Xmobar.Plugins.Monitors.MPD -import Xmobar.Plugins.Monitors.Common (runMBD) -#endif -#ifdef ALSA -import Xmobar.Plugins.Monitors.Volume -import Xmobar.Plugins.Monitors.Alsa -#endif -#ifdef MPRIS -import Xmobar.Plugins.Monitors.Mpris -#endif - -data Monitors = Network Interface Args Rate - | DynNetwork Args Rate - | BatteryP Args Args Rate - | BatteryN Args Args Rate Alias - | Battery Args Rate - | DiskU DiskSpec Args Rate - | DiskIO DiskSpec Args Rate - | Thermal Zone Args Rate - | ThermalZone ZoneNo Args Rate - | Memory Args Rate - | Swap Args Rate - | Cpu Args Rate - | MultiCpu Args Rate - | Brightness Args Rate - | CpuFreq Args Rate - | CoreTemp Args Rate - | TopProc Args Rate - | TopMem Args Rate - | Uptime Args Rate - | CatInt Int FilePath Args Rate -#ifdef WEATHER - | Weather Station Args Rate -#endif -#ifdef UVMETER - | UVMeter Station Args Rate -#endif -#ifdef IWLIB - | Wireless Interface Args Rate -#endif -#ifdef LIBMPD - | MPD Args Rate - | AutoMPD Args -#endif -#ifdef ALSA - | Volume String String Args Rate - | Alsa String String Args -#endif -#ifdef MPRIS - | Mpris1 String Args Rate - | Mpris2 String Args Rate -#endif - deriving (Show,Read,Eq) - -type Args = [String] -type Program = String -type Alias = String -type Station = String -type Zone = String -type ZoneNo = Int -type Interface = String -type Rate = Int -type DiskSpec = [(String, String)] - -instance Exec Monitors where -#ifdef WEATHER - alias (Weather s _ _) = s -#endif - alias (Network i _ _) = i - alias (DynNetwork _ _) = "dynnetwork" - alias (Thermal z _ _) = z - alias (ThermalZone z _ _) = "thermal" ++ show z - alias (Memory _ _) = "memory" - alias (Swap _ _) = "swap" - alias (Cpu _ _) = "cpu" - alias (MultiCpu _ _) = "multicpu" - alias (Battery _ _) = "battery" - alias BatteryP {} = "battery" - alias (BatteryN _ _ _ a)= a - alias (Brightness _ _) = "bright" - alias (CpuFreq _ _) = "cpufreq" - alias (TopProc _ _) = "top" - alias (TopMem _ _) = "topmem" - alias (CoreTemp _ _) = "coretemp" - alias DiskU {} = "disku" - alias DiskIO {} = "diskio" - alias (Uptime _ _) = "uptime" - alias (CatInt n _ _ _) = "cat" ++ show n -#ifdef UVMETER - alias (UVMeter s _ _) = "uv " ++ s -#endif -#ifdef IWLIB - alias (Wireless i _ _) = i ++ "wi" -#endif -#ifdef LIBMPD - alias (MPD _ _) = "mpd" - alias (AutoMPD _) = "autompd" -#endif -#ifdef ALSA - alias (Volume m c _ _) = m ++ ":" ++ c - alias (Alsa m c _) = "alsa:" ++ m ++ ":" ++ c -#endif -#ifdef MPRIS - alias (Mpris1 _ _ _) = "mpris1" - alias (Mpris2 _ _ _) = "mpris2" -#endif - start (Network i a r) = startNet i a r - start (DynNetwork a r) = startDynNet a r - start (Cpu a r) = startCpu a r - start (MultiCpu a r) = startMultiCpu a r - start (TopProc a r) = startTop a r - start (TopMem a r) = runM a topMemConfig runTopMem r -#ifdef WEATHER - start (Weather s a r) = runMD (a ++ [s]) weatherConfig runWeather r weatherReady -#endif - start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r - start (ThermalZone z a r) = - runM (a ++ [show z]) thermalZoneConfig runThermalZone r - start (Memory a r) = runM a memConfig runMem r - start (Swap a r) = runM a swapConfig runSwap r - start (Battery a r) = runM a battConfig runBatt r - start (BatteryP s a r) = runM a battConfig (runBatt' s) r - start (BatteryN s a r _) = runM a battConfig (runBatt' s) r - start (Brightness a r) = runM a brightConfig runBright r - start (CpuFreq a r) = runM a cpuFreqConfig runCpuFreq r - start (CoreTemp a r) = runM a coreTempConfig runCoreTemp r - start (DiskU s a r) = runM a diskUConfig (runDiskU s) r - start (DiskIO s a r) = startDiskIO s a r - start (Uptime a r) = runM a uptimeConfig runUptime r - start (CatInt _ s a r) = runM a catIntConfig (runCatInt s) r -#ifdef UVMETER - start (UVMeter s a r) = runM (a ++ [s]) uvConfig runUVMeter r -#endif -#ifdef IWLIB - start (Wireless i a r) = runM a wirelessConfig (runWireless i) r -#endif -#ifdef LIBMPD - start (MPD a r) = runMD a mpdConfig runMPD r mpdReady - start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady -#endif -#ifdef ALSA - start (Volume m c a r) = runM a volumeConfig (runVolume m c) r - start (Alsa m c a) = startAlsaPlugin m c a -#endif -#ifdef MPRIS - start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r - start (Mpris2 s a r) = runM a mprisConfig (runMPRIS2 s) r -#endif diff --git a/src/lib/Xmobar/Plugins/Monitors/Alsa.hs b/src/lib/Xmobar/Plugins/Monitors/Alsa.hs deleted file mode 100644 index 21a2786..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Batt.hs b/src/lib/Xmobar/Plugins/Monitors/Batt.hs deleted file mode 100644 index 80f4275..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Bright.hs b/src/lib/Xmobar/Plugins/Monitors/Bright.hs deleted file mode 100644 index fe72219..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/CatInt.hs b/src/lib/Xmobar/Plugins/Monitors/CatInt.hs deleted file mode 100644 index 781eded..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Common.hs b/src/lib/Xmobar/Plugins/Monitors/Common.hs deleted file mode 100644 index f683874..0000000 --- a/src/lib/Xmobar/Plugins/Monitors/Common.hs +++ /dev/null @@ -1,545 +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.Utils - --- $monitor - -type Monitor a = ReaderT MConfig IO a - -data MConfig = - MC { normalColor :: IORef (Maybe String) - , low :: IORef Int - , lowColor :: IORef (Maybe String) - , high :: IORef Int - , highColor :: IORef (Maybe String) - , template :: IORef String - , export :: IORef [String] - , ppad :: IORef Int - , decDigits :: IORef Int - , minWidth :: IORef Int - , maxWidth :: IORef Int - , maxWidthEllipsis :: IORef String - , padChars :: IORef String - , padRight :: IORef Bool - , barBack :: IORef String - , barFore :: IORef String - , barWidth :: IORef Int - , useSuffix :: IORef Bool - , naString :: IORef String - , maxTotalWidth :: IORef Int - , maxTotalWidthEllipsis :: IORef String - } - --- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState' -type Selector a = MConfig -> IORef a - -sel :: Selector a -> Monitor a -sel s = - do hs <- ask - liftIO $ readIORef (s hs) - -mods :: Selector a -> (a -> a) -> Monitor () -mods s m = - do v <- ask - io $ modifyIORef (s v) m - -setConfigValue :: a -> Selector a -> Monitor () -setConfigValue v s = - mods s (const v) - -getConfigValue :: Selector a -> Monitor a -getConfigValue = sel - -mkMConfig :: String - -> [String] - -> IO MConfig -mkMConfig tmpl exprts = - do lc <- newIORef Nothing - l <- newIORef 33 - nc <- newIORef Nothing - h <- newIORef 66 - hc <- newIORef Nothing - t <- newIORef tmpl - e <- newIORef exprts - p <- newIORef 0 - d <- newIORef 0 - mn <- newIORef 0 - mx <- newIORef 0 - mel <- newIORef "" - pc <- newIORef " " - pr <- newIORef False - bb <- newIORef ":" - bf <- newIORef "#" - bw <- newIORef 10 - up <- newIORef False - na <- newIORef "N/A" - mt <- newIORef 0 - mtel <- newIORef "" - return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel - -data Opts = HighColor String - | NormalColor String - | LowColor String - | Low String - | High String - | Template String - | PercentPad String - | DecDigits String - | MinWidth String - | MaxWidth String - | Width String - | WidthEllipsis String - | PadChars String - | PadAlign String - | BarBack String - | BarFore String - | BarWidth String - | UseSuffix String - | NAString String - | MaxTotalWidth String - | MaxTotalWidthEllipsis String - -options :: [OptDescr Opts] -options = - [ - Option "H" ["High"] (ReqArg High "number") "The high threshold" - , Option "L" ["Low"] (ReqArg Low "number") "The low threshold" - , Option "h" ["high"] (ReqArg HighColor "color number") "Color for the high threshold: ex \"#FF0000\"" - , Option "n" ["normal"] (ReqArg NormalColor "color number") "Color for the normal threshold: ex \"#00FF00\"" - , Option "l" ["low"] (ReqArg LowColor "color number") "Color for the low threshold: ex \"#0000FF\"" - , Option "t" ["template"] (ReqArg Template "output template") "Output template." - , Option "S" ["suffix"] (ReqArg UseSuffix "True/False") "Use % to display percents or other suffixes." - , Option "d" ["ddigits"] (ReqArg DecDigits "decimal digits") "Number of decimal digits to display." - , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width." - , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width") "Minimum field width" - , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width") "Maximum field width" - , Option "w" ["width"] (ReqArg Width "fixed width") "Fixed field width" - , Option "e" ["maxwidthellipsis"] (ReqArg WidthEllipsis "Maximum width ellipsis") "Ellipsis to be added to the field when it has reached its max width." - , Option "c" ["padchars"] (ReqArg PadChars "padding chars") "Characters to use for padding" - , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right" - , Option "b" ["bback"] (ReqArg BarBack "bar background") "Characters used to draw bar backgrounds" - , Option "f" ["bfore"] (ReqArg BarFore "bar foreground") "Characters used to draw bar foregrounds" - , Option "W" ["bwidth"] (ReqArg BarWidth "bar width") "Bar width" - , Option "x" ["nastring"] (ReqArg NAString "N/A string") "String used when the monitor is not available" - , Option "T" ["maxtwidth"] (ReqArg MaxTotalWidth "Maximum total width") "Maximum total width" - , Option "E" ["maxtwidthellipsis"] (ReqArg MaxTotalWidthEllipsis "Maximum total width ellipsis") "Ellipsis to be added to the total text when it has reached its max width." - ] - -doArgs :: [String] -> ([String] -> Monitor String) -> ([String] -> Monitor Bool) -> Monitor String -doArgs args action detect = - case getOpt Permute options args of - (o, n, []) -> do doConfigOptions o - ready <- detect n - if ready - then action n - else return "<Waiting...>" - (_, _, errs) -> return (concat errs) - -doConfigOptions :: [Opts] -> Monitor () -doConfigOptions [] = io $ return () -doConfigOptions (o:oo) = - do let next = doConfigOptions oo - nz s = let x = read s in max 0 x - bool = (`elem` ["True", "true", "Yes", "yes", "On", "on"]) - (case o of - High h -> setConfigValue (read h) high - Low l -> setConfigValue (read l) low - HighColor c -> setConfigValue (Just c) highColor - NormalColor c -> setConfigValue (Just c) normalColor - LowColor c -> setConfigValue (Just c) lowColor - Template t -> setConfigValue t template - PercentPad p -> setConfigValue (nz p) ppad - DecDigits d -> setConfigValue (nz d) decDigits - MinWidth w -> setConfigValue (nz w) minWidth - MaxWidth w -> setConfigValue (nz w) maxWidth - Width w -> setConfigValue (nz w) minWidth >> - setConfigValue (nz w) maxWidth - WidthEllipsis e -> setConfigValue e maxWidthEllipsis - PadChars s -> setConfigValue s padChars - PadAlign a -> setConfigValue ("r" `isPrefixOf` a) padRight - BarBack s -> setConfigValue s barBack - BarFore s -> setConfigValue s barFore - BarWidth w -> setConfigValue (nz w) barWidth - UseSuffix u -> setConfigValue (bool u) useSuffix - NAString s -> setConfigValue s naString - MaxTotalWidth w -> setConfigValue (nz w) maxTotalWidth - MaxTotalWidthEllipsis e -> setConfigValue e maxTotalWidthEllipsis) >> next - -runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int - -> (String -> IO ()) -> IO () -runM args conf action r = runMB args conf action (tenthSeconds r) - -runMD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int - -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () -runMD args conf action r = runMBD args conf action (tenthSeconds r) - -runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () - -> (String -> IO ()) -> IO () -runMB args conf action wait = runMBD args conf action wait (\_ -> return True) - -runMBD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () - -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () -runMBD args conf action wait detect cb = handle (cb . showException) loop - where ac = doArgs args action detect - loop = conf >>= runReaderT ac >>= cb >> wait >> loop - -showException :: SomeException -> String -showException = ("error: "++) . show . flip asTypeOf undefined - -io :: IO a -> Monitor a -io = liftIO - --- $parsers - -runP :: Parser [a] -> String -> IO [a] -runP p i = - case parse p "" i of - Left _ -> return [] - Right x -> return x - -getAllBut :: String -> Parser String -getAllBut s = - manyTill (noneOf s) (char $ head s) - -getNumbers :: Parser Float -getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n - -getNumbersAsString :: Parser String -getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n - -skipRestOfLine :: Parser Char -skipRestOfLine = - do many $ noneOf "\n\r" - newline - -getAfterString :: String -> Parser String -getAfterString s = - do { try $ manyTill skipRestOfLine $ string s - ; manyTill anyChar newline - } <|> return "" - -skipTillString :: String -> Parser String -skipTillString s = - manyTill skipRestOfLine $ string s - --- | Parses the output template string -templateStringParser :: Parser (String,String,String) -templateStringParser = - do { s <- nonPlaceHolder - ; com <- templateCommandParser - ; ss <- nonPlaceHolder - ; return (s, com, ss) - } - where - nonPlaceHolder = fmap concat . many $ - many1 (noneOf "<") <|> colorSpec <|> iconSpec - --- | Recognizes color specification and returns it unchanged -colorSpec :: Parser String -colorSpec = try (string "</fc>") <|> try ( - do string "<fc=" - s <- many1 (alphaNum <|> char ',' <|> char '#') - char '>' - return $ "<fc=" ++ s ++ ">") - --- | Recognizes icon specification and returns it unchanged -iconSpec :: Parser String -iconSpec = try (do string "<icon=" - i <- manyTill (noneOf ">") (try (string "/>")) - return $ "<icon=" ++ i ++ "/>") - --- | Parses the command part of the template string -templateCommandParser :: Parser String -templateCommandParser = - do { char '<' - ; com <- many $ noneOf ">" - ; char '>' - ; return com - } - --- | Combines the template parsers -templateParser :: Parser [(String,String,String)] -templateParser = many templateStringParser --"%") - -trimTo :: Int -> String -> String -> (Int, String) -trimTo n p "" = (n, p) -trimTo n p ('<':cs) = trimTo n p' s - where p' = p ++ "<" ++ takeWhile (/= '>') cs ++ ">" - s = drop 1 (dropWhile (/= '>') cs) -trimTo 0 p s = trimTo 0 p (dropWhile (/= '<') s) -trimTo n p s = let p' = takeWhile (/= '<') s - s' = dropWhile (/= '<') s - in - if length p' <= n - then trimTo (n - length p') (p ++ p') s' - else trimTo 0 (p ++ take n p') s' - --- | Takes a list of strings that represent the values of the exported --- keys. The strings are joined with the exported keys to form a map --- to be combined with 'combine' to the parsed template. Returns the --- final output of the monitor, trimmed to MaxTotalWidth if that --- configuration value is positive. -parseTemplate :: [String] -> Monitor String -parseTemplate l = - do t <- getConfigValue template - e <- getConfigValue export - w <- getConfigValue maxTotalWidth - ell <- getConfigValue maxTotalWidthEllipsis - let m = Map.fromList . zip e $ l - s <- parseTemplate' t m - let (n, s') = if w > 0 && length s > w - then trimTo (w - length ell) "" s - else (1, s) - return $ if n > 0 then s' else s' ++ ell - --- | Parses the template given to it with a map of export values and combines --- them -parseTemplate' :: String -> Map.Map String String -> Monitor String -parseTemplate' t m = - do s <- io $ runP templateParser t - combine m s - --- | Given a finite "Map" and a parsed template t produces the --- | resulting output string as the output of the monitor. -combine :: Map.Map String String -> [(String, String, String)] -> Monitor String -combine _ [] = return [] -combine m ((s,ts,ss):xs) = - do next <- combine m xs - str <- case Map.lookup ts m of - Nothing -> return $ "<" ++ ts ++ ">" - Just r -> let f "" = r; f n = n; in f <$> parseTemplate' r m - return $ s ++ str ++ ss ++ next - --- $strings - -type IconPattern = Int -> String - -parseIconPattern :: String -> IconPattern -parseIconPattern path = - let spl = splitOnPercent path - in \i -> intercalate (show i) spl - where splitOnPercent [] = [[]] - splitOnPercent ('%':'%':xs) = [] : splitOnPercent xs - splitOnPercent (x:xs) = - let rest = splitOnPercent xs - in (x : head rest) : tail rest - -type Pos = (Int, Int) - -takeDigits :: Int -> Float -> Float -takeDigits d n = - fromIntegral (round (n * fact) :: Int) / fact - where fact = 10 ^ d - -showDigits :: (RealFloat a) => Int -> a -> String -showDigits d n = showFFloat (Just d) n "" - -showWithUnits :: Int -> Int -> Float -> String -showWithUnits d n x - | x < 0 = '-' : showWithUnits d n (-x) - | n > 3 || x < 10^(d + 1) = show (round x :: Int) ++ units n - | x <= 1024 = showDigits d (x/1024) ++ units (n+1) - | otherwise = showWithUnits d (n+1) (x/1024) - where units = (!!) ["B", "K", "M", "G", "T"] - -padString :: Int -> Int -> String -> Bool -> String -> String -> String -padString mnw mxw pad pr ellipsis s = - let len = length s - rmin = if mnw <= 0 then 1 else mnw - rmax = if mxw <= 0 then max len rmin else mxw - (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin) - rlen = min (max rmn len) rmx - in if rlen < len then - take rlen s ++ ellipsis - else let ps = take (rlen - len) (cycle pad) - in if pr then s ++ ps else ps ++ s - -parseFloat :: String -> Float -parseFloat s = case readFloat s of - (v, _):_ -> v - _ -> 0 - -parseInt :: String -> Int -parseInt s = case readDec s of - (v, _):_ -> v - _ -> 0 - -floatToPercent :: Float -> Monitor String -floatToPercent n = - do pad <- getConfigValue ppad - pc <- getConfigValue padChars - pr <- getConfigValue padRight - up <- getConfigValue useSuffix - let p = showDigits 0 (n * 100) - ps = if up then "%" else "" - return $ padString pad pad pc pr "" p ++ ps - -stringParser :: Pos -> B.ByteString -> String -stringParser (x,y) = - B.unpack . li x . B.words . li y . B.lines - where li i l | length l > i = l !! i - | otherwise = B.empty - -setColor :: String -> Selector (Maybe String) -> Monitor String -setColor str s = - do a <- getConfigValue s - case a of - Nothing -> return str - Just c -> return $ - "<fc=" ++ c ++ ">" ++ str ++ "</fc>" - -showWithPadding :: String -> Monitor String -showWithPadding s = - do mn <- getConfigValue minWidth - mx <- getConfigValue maxWidth - p <- getConfigValue padChars - pr <- getConfigValue padRight - ellipsis <- getConfigValue maxWidthEllipsis - return $ padString mn mx p pr ellipsis s - -colorizeString :: (Num a, Ord a) => a -> String -> Monitor String -colorizeString x s = do - h <- getConfigValue high - l <- getConfigValue low - let col = setColor s - [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low - head $ [col highColor | x > hh ] ++ - [col normalColor | x > ll ] ++ - [col lowColor | True] - -showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String -showWithColors f x = showWithPadding (f x) >>= colorizeString x - -showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String -showWithColors' str = showWithColors (const str) - -showPercentsWithColors :: [Float] -> Monitor [String] -showPercentsWithColors fs = - do fstrs <- mapM floatToPercent fs - zipWithM (showWithColors . const) fstrs (map (*100) fs) - -showPercentWithColors :: Float -> Monitor String -showPercentWithColors f = fmap head $ showPercentsWithColors [f] - -showPercentBar :: Float -> Float -> Monitor String -showPercentBar v x = do - bb <- getConfigValue barBack - bf <- getConfigValue barFore - bw <- getConfigValue barWidth - let len = min bw $ round (fromIntegral bw * x) - s <- colorizeString v (take len $ cycle bf) - return $ s ++ take (bw - len) (cycle bb) - -showIconPattern :: Maybe IconPattern -> Float -> Monitor String -showIconPattern Nothing _ = return "" -showIconPattern (Just str) x = return $ str $ convert $ 100 * x - where convert val - | t <= 0 = 0 - | t > 8 = 8 - | otherwise = t - where t = round val `div` 12 - -showVerticalBar :: Float -> Float -> Monitor String -showVerticalBar v x = colorizeString v [convert $ 100 * x] - where convert :: Float -> Char - convert val - | t <= 9600 = ' ' - | t > 9608 = chr 9608 - | otherwise = chr t - where t = 9600 + (round val `div` 12) - -logScaling :: Float -> Float -> Monitor Float -logScaling f v = do - h <- fromIntegral `fmap` getConfigValue high - l <- fromIntegral `fmap` getConfigValue low - bw <- fromIntegral `fmap` getConfigValue barWidth - let [ll, hh] = sort [l, h] - scaled x | x == 0.0 = 0 - | x <= ll = 1 / bw - | otherwise = f + logBase 2 (x / hh) / bw - return $ scaled v - -showLogBar :: Float -> Float -> Monitor String -showLogBar f v = logScaling f v >>= showPercentBar v - -showLogVBar :: Float -> Float -> Monitor String -showLogVBar f v = logScaling f v >>= showVerticalBar v - -showLogIconPattern :: Maybe IconPattern -> Float -> Float -> Monitor String -showLogIconPattern str f v = logScaling f v >>= showIconPattern str diff --git a/src/lib/Xmobar/Plugins/Monitors/CoreCommon.hs b/src/lib/Xmobar/Plugins/Monitors/CoreCommon.hs deleted file mode 100644 index a84198e..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/CoreTemp.hs b/src/lib/Xmobar/Plugins/Monitors/CoreTemp.hs deleted file mode 100644 index 48fe428..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Cpu.hs b/src/lib/Xmobar/Plugins/Monitors/Cpu.hs deleted file mode 100644 index 6befe7d..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/CpuFreq.hs b/src/lib/Xmobar/Plugins/Monitors/CpuFreq.hs deleted file mode 100644 index 1afedfa..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Disk.hs b/src/lib/Xmobar/Plugins/Monitors/Disk.hs deleted file mode 100644 index 3f89629..0000000 --- a/src/lib/Xmobar/Plugins/Monitors/Disk.hs +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Plugins.Monitors.Disk --- Copyright : (c) 2010, 2011, 2012, 2014, 2018 Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Disk usage and throughput monitors for Xmobar --- ------------------------------------------------------------------------------ - -module Xmobar.Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where - -import Xmobar.Plugins.Monitors.Common -import Xmobar.System.StatFS - -import Data.IORef (IORef, newIORef, readIORef, writeIORef) - -import Control.Exception (SomeException, handle) -import Control.Monad (zipWithM) -import qualified Data.ByteString.Lazy.Char8 as B -import Data.List (isPrefixOf, find) -import Data.Maybe (catMaybes) -import System.Directory (canonicalizePath, doesFileExist) -import System.Console.GetOpt - -data DiskIOOpts = DiskIOOpts - { totalIconPattern :: Maybe IconPattern - , writeIconPattern :: Maybe IconPattern - , readIconPattern :: Maybe IconPattern - } - -parseDiskIOOpts :: [String] -> IO DiskIOOpts -parseDiskIOOpts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs - where defaultOpts = DiskIOOpts - { totalIconPattern = Nothing - , writeIconPattern = Nothing - , readIconPattern = Nothing - } - options = - [ Option "" ["total-icon-pattern"] (ReqArg (\x o -> - o { totalIconPattern = Just $ parseIconPattern x}) "") "" - , Option "" ["write-icon-pattern"] (ReqArg (\x o -> - o { writeIconPattern = Just $ parseIconPattern x}) "") "" - , Option "" ["read-icon-pattern"] (ReqArg (\x o -> - o { readIconPattern = Just $ parseIconPattern x}) "") "" - ] - -diskIOConfig :: IO MConfig -diskIOConfig = mkMConfig "" ["total", "read", "write" - ,"totalbar", "readbar", "writebar" - ,"totalvbar", "readvbar", "writevbar" - ,"totalipat", "readipat", "writeipat" - ] - -data DiskUOpts = DiskUOpts - { freeIconPattern :: Maybe IconPattern - , usedIconPattern :: Maybe IconPattern - } - -parseDiskUOpts :: [String] -> IO DiskUOpts -parseDiskUOpts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs - where defaultOpts = DiskUOpts - { freeIconPattern = Nothing - , usedIconPattern = Nothing - } - options = - [ Option "" ["free-icon-pattern"] (ReqArg (\x o -> - o { freeIconPattern = Just $ parseIconPattern x}) "") "" - , Option "" ["used-icon-pattern"] (ReqArg (\x o -> - o { usedIconPattern = Just $ parseIconPattern x}) "") "" - ] - -diskUConfig :: IO MConfig -diskUConfig = mkMConfig "" - [ "size", "free", "used", "freep", "usedp" - , "freebar", "freevbar", "freeipat" - , "usedbar", "usedvbar", "usedipat" - ] - -type DevName = String -type Path = String -type DevDataRef = IORef [(DevName, [Float])] - -mountedDevices :: [String] -> IO [(DevName, Path)] -mountedDevices req = do - s <- B.readFile "/etc/mtab" - parse `fmap` mapM mbcanon (devs s) - where - mbcanon (d, p) = doesFileExist d >>= \e -> - if e - then Just `fmap` canon (d,p) - else return Nothing - canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} - devs = filter isDev . map (firstTwo . B.words) . B.lines - parse = map undev . filter isReq . catMaybes - firstTwo (a:b:_) = (B.unpack a, B.unpack b) - firstTwo _ = ("", "") - isDev (d, _) = "/dev/" `isPrefixOf` d - isReq (d, p) = p `elem` req || drop 5 d `elem` req - undev (d, f) = (drop 5 d, f) - -diskDevices :: [String] -> IO [(DevName, Path)] -diskDevices req = do - s <- B.readFile "/proc/diskstats" - parse `fmap` mapM canon (devs s) - where - canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} - devs = map (third . B.words) . B.lines - parse = map undev . filter isReq - third (_:_:c:_) = ("/dev/" ++ B.unpack c, B.unpack c) - third _ = ("", "") - isReq (d, p) = p `elem` req || drop 5 d `elem` req - undev (d, f) = (drop 5 d, f) - -mountedOrDiskDevices :: [String] -> IO [(DevName, Path)] -mountedOrDiskDevices req = do - mnt <- mountedDevices req - case mnt of - [] -> diskDevices req - other -> return other - -diskData :: IO [(DevName, [Float])] -diskData = do - s <- B.readFile "/proc/diskstats" - let extract ws = (head ws, map read (tail ws)) - return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s) - -mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])] -mountedData dref devs = do - dt <- readIORef dref - dt' <- diskData - writeIORef dref dt' - return $ map (parseDev (zipWith diff dt' dt)) devs - where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys) - -parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float]) -parseDev dat dev = - case find ((==dev) . fst) dat of - Nothing -> (dev, [0, 0, 0]) - Just (_, xs) -> - let rSp = speed (xs !! 2) (xs !! 3) - wSp = speed (xs !! 6) (xs !! 7) - sp = speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7) - speed x t = if t == 0 then 0 else 500 * x / t - dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0] - in (dev, dat') - -speedToStr :: Float -> String -speedToStr = showWithUnits 2 1 - -sizeToStr :: Integer -> String -sizeToStr = showWithUnits 3 0 . fromIntegral - -findTempl :: DevName -> Path -> [(String, String)] -> String -findTempl dev path disks = - case find devOrPath disks of - Just (_, t) -> t - Nothing -> "" - where devOrPath (d, _) = d == dev || d == path - -devTemplates :: [(String, String)] - -> [(DevName, Path)] - -> [(DevName, [Float])] - -> [(String, [Float])] -devTemplates disks mounted dat = - map (\(d, p) -> (findTempl d p disks, findData d)) mounted - where findData dev = case find ((==dev) . fst) dat of - Nothing -> [0, 0, 0] - Just (_, xs) -> xs - -runDiskIO' :: DiskIOOpts -> (String, [Float]) -> Monitor String -runDiskIO' opts (tmp, xs) = do - s <- mapM (showWithColors speedToStr) xs - b <- mapM (showLogBar 0.8) xs - vb <- mapM (showLogVBar 0.8) xs - ipat <- mapM (\(f,v) -> showLogIconPattern (f opts) 0.8 v) - $ zip [totalIconPattern, readIconPattern, writeIconPattern] xs - setConfigValue tmp template - parseTemplate $ s ++ b ++ vb ++ ipat - -runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String -runDiskIO dref disks argv = do - opts <- io $ parseDiskIOOpts argv - dev <- io $ mountedOrDiskDevices (map fst disks) - dat <- io $ mountedData dref (map fst dev) - strs <- mapM (runDiskIO' opts) $ devTemplates disks dev dat - return $ unwords strs - -startDiskIO :: [(String, String)] -> - [String] -> Int -> (String -> IO ()) -> IO () -startDiskIO disks args rate cb = do - dev <- mountedOrDiskDevices (map fst disks) - dref <- newIORef (map (\d -> (fst d, repeat 0)) dev) - _ <- mountedData dref (map fst dev) - runM args diskIOConfig (runDiskIO dref disks) rate cb - -fsStats :: String -> IO [Integer] -fsStats path = do - stats <- getFileSystemStats path - case stats of - Nothing -> return [0, 0, 0] - Just f -> let tot = fsStatByteCount f - free = fsStatBytesAvailable f - used = fsStatBytesUsed f - in return [tot, free, used] - -runDiskU' :: DiskUOpts -> String -> String -> Monitor String -runDiskU' opts tmp path = do - setConfigValue tmp template - [total, free, diff] <- io (handle ign $ fsStats path) - let strs = map sizeToStr [free, diff] - freep = if total > 0 then free * 100 `div` total else 0 - fr = fromIntegral freep / 100 - s <- zipWithM showWithColors' strs [freep, 100 - freep] - sp <- showPercentsWithColors [fr, 1 - fr] - fb <- showPercentBar (fromIntegral freep) fr - fvb <- showVerticalBar (fromIntegral freep) fr - fipat <- showIconPattern (freeIconPattern opts) fr - ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr) - uvb <- showVerticalBar (fromIntegral $ 100 - freep) (1 - fr) - uipat <- showIconPattern (usedIconPattern opts) (1 - fr) - parseTemplate $ [sizeToStr total] ++ s ++ sp ++ [fb,fvb,fipat,ub,uvb,uipat] - where ign = const (return [0, 0, 0]) :: SomeException -> IO [Integer] - - -runDiskU :: [(String, String)] -> [String] -> Monitor String -runDiskU disks argv = do - devs <- io $ mountedDevices (map fst disks) - opts <- io $ parseDiskUOpts argv - strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs - return $ unwords strs diff --git a/src/lib/Xmobar/Plugins/Monitors/MPD.hs b/src/lib/Xmobar/Plugins/Monitors/MPD.hs deleted file mode 100644 index 9525254..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Mem.hs b/src/lib/Xmobar/Plugins/Monitors/Mem.hs deleted file mode 100644 index d69921b..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Mpris.hs b/src/lib/Xmobar/Plugins/Monitors/Mpris.hs deleted file mode 100644 index 3556649..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/MultiCpu.hs b/src/lib/Xmobar/Plugins/Monitors/MultiCpu.hs deleted file mode 100644 index 3db3b5f..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Net.hs b/src/lib/Xmobar/Plugins/Monitors/Net.hs deleted file mode 100644 index 81a5f6b..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Swap.hs b/src/lib/Xmobar/Plugins/Monitors/Swap.hs deleted file mode 100644 index fcaab84..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Thermal.hs b/src/lib/Xmobar/Plugins/Monitors/Thermal.hs deleted file mode 100644 index 320ae17..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/ThermalZone.hs b/src/lib/Xmobar/Plugins/Monitors/ThermalZone.hs deleted file mode 100644 index bc46b59..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Top.hs b/src/lib/Xmobar/Plugins/Monitors/Top.hs deleted file mode 100644 index d6df249..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/UVMeter.hs b/src/lib/Xmobar/Plugins/Monitors/UVMeter.hs deleted file mode 100644 index 079177f..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Uptime.hs b/src/lib/Xmobar/Plugins/Monitors/Uptime.hs deleted file mode 100644 index 235fc85..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Volume.hs b/src/lib/Xmobar/Plugins/Monitors/Volume.hs deleted file mode 100644 index 1d3281c..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Weather.hs b/src/lib/Xmobar/Plugins/Monitors/Weather.hs deleted file mode 100644 index cb5bf07..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/Monitors/Wireless.hs b/src/lib/Xmobar/Plugins/Monitors/Wireless.hs deleted file mode 100644 index 545f6bc..0000000 --- a/src/lib/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/lib/Xmobar/Plugins/PipeReader.hs b/src/lib/Xmobar/Plugins/PipeReader.hs deleted file mode 100644 index f18b9cb..0000000 --- a/src/lib/Xmobar/Plugins/PipeReader.hs +++ /dev/null @@ -1,48 +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(PipeReader(..)) where - -import System.IO -import Xmobar.Utils(hGetLineSafe) -import Xmobar.Run.Commands(Exec(..)) -import Xmobar.System.Environment(expandEnv) -import System.Posix.Files -import Control.Concurrent(threadDelay) -import Control.Exception -import Control.Monad(forever, unless) -import Control.Applicative ((<$>)) - -data PipeReader = PipeReader String String - deriving (Read, Show) - -instance Exec PipeReader where - alias (PipeReader _ a) = a - start (PipeReader p _) cb = do - (def, pipe) <- split ':' <$> expandEnv p - unless (null def) (cb def) - checkPipe pipe - h <- openFile pipe ReadWriteMode - forever (hGetLineSafe h >>= cb) - where - split c xs | c `elem` xs = let (pre, post) = span (c /=) xs - in (pre, dropWhile (c ==) post) - | otherwise = ([], xs) - -checkPipe :: FilePath -> IO () -checkPipe file = - handle (\(SomeException _) -> waitForPipe) $ do - status <- getFileStatus file - unless (isNamedPipe status) waitForPipe - where waitForPipe = threadDelay 1000000 >> checkPipe file diff --git a/src/lib/Xmobar/Plugins/StdinReader.hs b/src/lib/Xmobar/Plugins/StdinReader.hs deleted file mode 100644 index bed7f5c..0000000 --- a/src/lib/Xmobar/Plugins/StdinReader.hs +++ /dev/null @@ -1,45 +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.Actions (stripActions) -import Xmobar.Utils (hGetLineSafe) -import Xmobar.Run.Commands - -data StdinReader = StdinReader | UnsafeStdinReader - deriving (Read, Show) - -instance Exec StdinReader where - start stdinReader cb = do - s <- handle (\(SomeException e) -> do hPrint stderr e; return "") - (hGetLineSafe stdin) - cb $ escape stdinReader s - eof <- isEOF - if eof - then exitImmediately ExitSuccess - else start stdinReader cb - -escape :: StdinReader -> String -> String -escape StdinReader = stripActions -escape UnsafeStdinReader = id diff --git a/src/lib/Xmobar/Plugins/XMonadLog.hs b/src/lib/Xmobar/Plugins/XMonadLog.hs deleted file mode 100644 index a4f17bb..0000000 --- a/src/lib/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.Run.Commands -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar) -import Xmobar.Utils (nextEvent') -import Xmobar.Actions (stripActions) - -data XMonadLog = XMonadLog - | UnsafeXMonadLog - | XPropertyLog String - | UnsafeXPropertyLog String - | NamedXPropertyLog String String - | UnsafeNamedXPropertyLog String String - deriving (Read, Show) - -instance Exec XMonadLog where - alias XMonadLog = "XMonadLog" - alias UnsafeXMonadLog = "UnsafeXMonadLog" - alias (XPropertyLog atom) = atom - alias (NamedXPropertyLog _ name) = name - alias (UnsafeXPropertyLog atom) = atom - alias (UnsafeNamedXPropertyLog _ name) = name - - start x cb = do - let atom = case x of - XMonadLog -> "_XMONAD_LOG" - UnsafeXMonadLog -> "_XMONAD_LOG" - XPropertyLog a -> a - UnsafeXPropertyLog a -> a - NamedXPropertyLog a _ -> a - UnsafeNamedXPropertyLog a _ -> a - sanitize = case x of - UnsafeXMonadLog -> id - UnsafeXPropertyLog _ -> id - UnsafeNamedXPropertyLog _ _ -> id - _ -> stripActions - - d <- openDisplay "" - xlog <- internAtom d atom False - - root <- rootWindow d (defaultScreen d) - selectInput d root propertyChangeMask - - let update = do - mwp <- getWindowProperty8 d xlog root - maybe (return ()) (cb . sanitize . decodeCChar) mwp - - update - - allocaXEvent $ \ep -> forever $ do - nextEvent' d ep - e <- getEvent ep - case e of - PropertyEvent { ev_atom = a } | a == xlog -> update - _ -> return () - - return () - -decodeCChar :: [CChar] -> String -#ifdef UTF8 -#undef UTF8 -decodeCChar = UTF8.decode . map fromIntegral -#define UTF8 -#else -decodeCChar = map (toEnum . fromIntegral) -#endif diff --git a/src/lib/Xmobar/Run/Commands.hs b/src/lib/Xmobar/Run/Commands.hs deleted file mode 100644 index 198edee..0000000 --- a/src/lib/Xmobar/Run/Commands.hs +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Commands --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- The 'Exec' class and the 'Command' data type. --- --- The 'Exec' class rappresents the executable types, whose constructors may --- appear in the 'Config.commands' field of the 'Config.Config' data type. --- --- The 'Command' data type is for OS commands to be run by xmobar --- ------------------------------------------------------------------------------ - -module Xmobar.Run.Commands (Command (..), Exec (..)) where - -import Prelude -import Control.Exception (handle, SomeException(..)) -import Data.Char -import System.Process -import System.Exit -import System.IO (hClose) - -import Xmobar.System.Signal -import Xmobar.Utils (hGetLineSafe, tenthSeconds) - -class Show e => Exec e where - alias :: e -> String - alias e = takeWhile (not . isSpace) $ show e - rate :: e -> Int - rate _ = 10 - run :: e -> IO String - run _ = return "" - start :: e -> (String -> IO ()) -> IO () - start e cb = go - where go = run e >>= cb >> tenthSeconds (rate e) >> go - trigger :: e -> (Maybe SignalType -> IO ()) -> IO () - trigger _ sh = sh Nothing - -data Command = Com Program Args Alias Rate - | ComX Program Args String Alias Rate - deriving (Show,Read,Eq) - -type Args = [String] -type Program = String -type Alias = String -type Rate = Int - -instance Exec Command where - alias (ComX p _ _ a _) = - if p /= "" then (if a == "" then p else a) else "" - alias (Com p a al r) = alias (ComX p a "" al r) - start (Com p as al r) cb = - start (ComX p as ("Could not execute command " ++ p) al r) cb - start (ComX prog args msg _ r) cb = if r > 0 then go else exec - where go = exec >> tenthSeconds r >> go - exec = do - (i,o,e,p) <- runInteractiveProcess prog args Nothing Nothing - exit <- waitForProcess p - let closeHandles = hClose o >> hClose i >> hClose e - getL = handle (\(SomeException _) -> return "") - (hGetLineSafe o) - case exit of - ExitSuccess -> do str <- getL - closeHandles - cb str - _ -> closeHandles >> cb msg diff --git a/src/lib/Xmobar/Run/EventLoop.hs b/src/lib/Xmobar/Run/EventLoop.hs deleted file mode 100644 index a4385d1..0000000 --- a/src/lib/Xmobar/Run/EventLoop.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- --- | --- Module: Xmobar.X11.EventLoop --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 19:40 --- --- --- Event loop --- ------------------------------------------------------------------------------- - - -module Xmobar.Run.EventLoop (startLoop, startCommand) where - -import Prelude hiding (lookup) -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama -import Graphics.X11.Xrandr - -import Control.Arrow ((&&&)) -import Control.Applicative ((<$>)) -import Control.Monad.Reader -import Control.Concurrent -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.STM -import Control.Exception (handle, SomeException(..)) -import Data.Bits -import Data.Map hiding (foldr, map, filter) -import Data.Maybe (fromJust, isJust) - -import Xmobar.Config -import Xmobar.Actions -import Xmobar.Utils -import Xmobar.System.Signal -import Xmobar.Run.Commands -import Xmobar.Run.Runnable -import Xmobar.X11.Parsers -import Xmobar.X11.Window -import Xmobar.X11.XUtil -import Xmobar.X11.Draw -import Xmobar.X11.Bitmap as Bitmap -import Xmobar.X11.Types - -#ifdef XFT -import Graphics.X11.Xft -#endif - -#ifdef DBUS -import Xmobar.System.DBus -#endif - -runX :: XConf -> X () -> IO () -runX xc f = runReaderT f xc - --- | Starts the main event loop and threads -startLoop :: XConf -> TMVar SignalType -> [[([Async ()], TVar String)]] - -> IO () -startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do -#ifdef XFT - xftInitFtLibrary -#endif - tv <- atomically $ newTVar [] - _ <- forkIO (handle (handler "checker") (checker tv [] vs sig)) -#ifdef THREADED_RUNTIME - _ <- forkOS (handle (handler "eventer") (eventer sig)) -#else - _ <- forkIO (handle (handler "eventer") (eventer sig)) -#endif -#ifdef DBUS - runIPC sig -#endif - eventLoop tv xcfg [] sig - where - handler thing (SomeException e) = - void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) - -- Reacts on events from X - eventer signal = - allocaXEvent $ \e -> do - dpy <- openDisplay "" - xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) - - forever $ do -#ifdef THREADED_RUNTIME - nextEvent dpy e -#else - nextEvent' dpy e -#endif - ev <- getEvent e - case ev of - ConfigureEvent {} -> atomically $ putTMVar signal Reposition - ExposeEvent {} -> atomically $ putTMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) - _ -> return () - --- | Send signal to eventLoop every time a var is updated -checker :: TVar [String] - -> [String] - -> [[([Async ()], TVar String)]] - -> TMVar SignalType - -> IO () -checker tvar ov vs signal = do - nval <- atomically $ do - nv <- mapM concatV vs - guard (nv /= ov) - writeTVar tvar nv - return nv - atomically $ putTMVar signal Wakeup - checker tvar nval vs signal - where - concatV = fmap concat . mapM (readTVar . snd) - - --- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] - -> XConf - -> [([Action], Position, Position)] - -> TMVar SignalType - -> IO () -eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do - typ <- atomically $ takeTMVar signal - case typ of - Wakeup -> do - str <- updateString cfg tv - xc' <- updateCache d w is (iconRoot cfg) str >>= - \c -> return xc { iconS = c } - as' <- updateActions xc r str - runX xc' $ drawInWin r str - eventLoop tv xc' as' signal - - Reposition -> - reposWindow cfg - - ChangeScreen -> do - ncfg <- updateConfigPosition cfg - reposWindow ncfg - - Hide t -> hide (t*100*1000) - Reveal t -> reveal (t*100*1000) - Toggle t -> toggle t - - TogglePersistent -> eventLoop - tv xc { config = cfg { persistent = not $ persistent cfg } } as signal - - Action but x -> action but x - - where - isPersistent = not $ persistent cfg - - hide t - | t == 0 = - when isPersistent (hideWindow d w) >> eventLoop tv xc as signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - eventLoop tv xc as signal - - reveal t - | t == 0 = do - when isPersistent (showWindow r cfg d w) - eventLoop tv xc as signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) - eventLoop tv xc as signal - - toggle t = do - ismapped <- isMapped d w - atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - eventLoop tv xc as signal - - reposWindow rcfg = do - r' <- repositionWin d w (head fs) rcfg - eventLoop tv (XConf d r' w fs vos is rcfg) as signal - - updateConfigPosition ocfg = - case position ocfg of - OnScreen n o -> do - srs <- getScreenInfo d - return (if n == length srs - then - (ocfg {position = OnScreen 1 o}) - else - (ocfg {position = OnScreen (n+1) o})) - o -> return (ocfg {position = OnScreen 1 o}) - - action button x = do - mapM_ runAction $ - filter (\(Spawn b _) -> button `elem` b) $ - concatMap (\(a,_,_) -> a) $ - filter (\(_, from, to) -> x >= from && x <= to) as - eventLoop tv xc as signal - --- $command - --- | Runs a command as an independent thread and returns its Async handles --- and the TVar the command will be writing to. -startCommand :: TMVar SignalType - -> (Runnable,String,String) - -> IO ([Async ()], TVar String) -startCommand sig (com,s,ss) - | alias com == "" = do var <- atomically $ newTVar is - atomically $ writeTVar var (s ++ ss) - return ([], var) - | otherwise = do var <- atomically $ newTVar is - let cb str = atomically $ writeTVar var (s ++ str ++ ss) - a1 <- async $ start com cb - a2 <- async $ trigger com $ maybe (return ()) - (atomically . putTMVar sig) - return ([a1, a2], var) - where is = s ++ "Updating..." ++ ss - -updateString :: Config -> TVar [String] - -> IO [[(Widget, String, Int, Maybe [Action])]] -updateString conf v = do - s <- readTVarIO v - let l:c:r:_ = s ++ repeat "" - liftIO $ mapM (parseString conf) [l, c, r] - -updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]] - -> IO [([Action], Position, Position)] -updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do - let (d,fs) = (display &&& fontListS) conf - strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] - strLn = liftIO . mapM getCoords - iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) - getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw) - getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) - partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ - filter (\(a, _,_) -> isJust a) $ - scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) - (Nothing, 0, off) - xs - totSLen = foldr (\(_,_,len) -> (+) len) 0 - remWidth xs = fi wid - totSLen xs - offs = 1 - offset a xs = case a of - C -> (remWidth xs + offs) `div` 2 - R -> remWidth xs - L -> offs - fmap concat $ mapM (\(a,xs) -> - (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ - zip [L,C,R] [left,center,right] diff --git a/src/lib/Xmobar/Run/Runnable.hs b/src/lib/Xmobar/Run/Runnable.hs deleted file mode 100644 index 962166e..0000000 --- a/src/lib/Xmobar/Run/Runnable.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Runnable --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- The existential type to store the list of commands to be executed. --- I must thank Claus Reinke for the help in understanding the mysteries of --- reading existential types. The Read instance of Runnable must be credited to --- him. --- --- See here: --- http:\/\/www.haskell.org\/pipermail\/haskell-cafe\/2007-July\/028227.html --- ------------------------------------------------------------------------------ - -module Xmobar.Run.Runnable where - -import Control.Monad -import Text.Read -import Xmobar.Run.Types (runnableTypes) -import Xmobar.Run.Commands - -data Runnable = forall r . (Exec r, Read r, Show r) => Run r - -instance Exec Runnable where - start (Run a) = start a - alias (Run a) = alias a - trigger (Run a) = trigger a - -instance Show Runnable where - show (Run x) = show x - -instance Read Runnable where - readPrec = readRunnable - -class ReadAsAnyOf ts ex where - -- | Reads an existential type as any of hidden types ts - readAsAnyOf :: ts -> ReadPrec ex - -instance ReadAsAnyOf () ex where - readAsAnyOf ~() = mzero - -instance (Read t, Exec t, ReadAsAnyOf ts Runnable) => ReadAsAnyOf (t,ts) Runnable where - readAsAnyOf ~(t,ts) = r t `mplus` readAsAnyOf ts - where r ty = do { m <- readPrec; return (Run (m `asTypeOf` ty)) } - --- | The 'Prelude.Read' parser for the 'Runnable' existential type. It --- needs an 'Prelude.undefined' with a type signature containing the --- list of all possible types hidden within 'Runnable'. See 'Config.runnableTypes'. --- Each hidden type must have a 'Prelude.Read' instance. -readRunnable :: ReadPrec Runnable -readRunnable = prec 10 $ do - Ident "Run" <- lexP - parens $ readAsAnyOf runnableTypes diff --git a/src/lib/Xmobar/Run/Runnable.hs-boot b/src/lib/Xmobar/Run/Runnable.hs-boot deleted file mode 100644 index f272d81..0000000 --- a/src/lib/Xmobar/Run/Runnable.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Xmobar.Run.Runnable where -import Xmobar.Run.Commands - -data Runnable = forall r . (Exec r,Read r,Show r) => Run r - -instance Read Runnable -instance Exec Runnable diff --git a/src/lib/Xmobar/Run/Template.hs b/src/lib/Xmobar/Run/Template.hs deleted file mode 100644 index 5bada89..0000000 --- a/src/lib/Xmobar/Run/Template.hs +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Xmobar.Template --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sun Nov 25, 2018 05:49 --- --- --- Handling the top-level output template --- ------------------------------------------------------------------------------- - - -module Xmobar.Run.Template(parseCommands) where - -import qualified Data.Map as Map -import Text.ParserCombinators.Parsec - -import Xmobar.Run.Commands -import Xmobar.Run.Runnable -import Xmobar.Config - --- | Parses the output template string -templateStringParser :: Config -> Parser (String,String,String) -templateStringParser c = do - s <- allTillSep c - com <- templateCommandParser c - ss <- allTillSep c - return (com, s, ss) - --- | Parses the command part of the template string -templateCommandParser :: Config -> Parser String -templateCommandParser c = - let chr = char . head . sepChar - in between (chr c) (chr c) (allTillSep c) - --- | Combines the template parsers -templateParser :: Config -> Parser [(String,String,String)] -templateParser = many . templateStringParser - --- | Actually runs the template parsers -parseCommands :: Config -> String -> IO [(Runnable,String,String)] -parseCommands c s = - do str <- case parse (templateParser c) "" s of - Left _ -> return [("", s, "")] - Right x -> return x - let cl = map alias (commands c) - m = Map.fromList $ zip cl (commands c) - return $ combine c m str - --- | Given a finite "Map" and a parsed template produce the resulting --- output string. -combine :: Config -> Map.Map String Runnable - -> [(String, String, String)] -> [(Runnable,String,String)] -combine _ _ [] = [] -combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs - where com = Map.findWithDefault dflt ts m - dflt = Run $ Com ts [] [] 10 - -allTillSep :: Config -> Parser String -allTillSep = many . noneOf . sepChar diff --git a/src/lib/Xmobar/Run/Types.hs b/src/lib/Xmobar/Run/Types.hs deleted file mode 100644 index 4fb526a..0000000 --- a/src/lib/Xmobar/Run/Types.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE TypeOperators, CPP #-} ------------------------------------------------------------------------------- --- | --- Module: Xmobar.Run.Types --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sun Nov 25, 2018 07:17 --- --- --- An enumeration of all runnable types --- ------------------------------------------------------------------------------- - - -module Xmobar.Run.Types(runnableTypes) where - -import Xmobar.Run.Commands - -import {-# SOURCE #-} Xmobar.Run.Runnable() -import Xmobar.Plugins.Monitors -import Xmobar.Plugins.Date -import Xmobar.Plugins.PipeReader -import Xmobar.Plugins.BufferedPipeReader -import Xmobar.Plugins.MarqueePipeReader -import Xmobar.Plugins.CommandReader -import Xmobar.Plugins.StdinReader -import Xmobar.Plugins.XMonadLog -import Xmobar.Plugins.EWMH -import Xmobar.Plugins.Kbd -import Xmobar.Plugins.Locks - -#ifdef INOTIFY -import Xmobar.Plugins.Mail -import Xmobar.Plugins.MBox -#endif - -#ifdef DATEZONE -import Xmobar.Plugins.DateZone -#endif - --- | An alias for tuple types that is more convenient for long lists. -type a :*: b = (a, b) -infixr :*: - --- | This is the list of types that can be hidden inside --- 'Runnable.Runnable', the existential type that stores all commands --- to be executed by Xmobar. It is used by 'Runnable.readRunnable' in --- the 'Runnable.Runnable' Read instance. To install a plugin just add --- the plugin's type to the list of types (separated by ':*:') appearing in --- this function's type signature. -runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: - BufferedPipeReader :*: CommandReader :*: StdinReader :*: - XMonadLog :*: EWMH :*: Kbd :*: Locks :*: -#ifdef INOTIFY - Mail :*: MBox :*: -#endif -#ifdef DATEZONE - DateZone :*: -#endif - MarqueePipeReader :*: () -runnableTypes = undefined diff --git a/src/lib/Xmobar/System/DBus.hs b/src/lib/Xmobar/System/DBus.hs deleted file mode 100644 index 103a5a9..0000000 --- a/src/lib/Xmobar/System/DBus.hs +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : DBus --- Copyright : (c) Jochen Keil --- License : BSD-style (see LICENSE) --- --- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> --- Stability : unstable --- Portability : unportable --- --- DBus IPC module for Xmobar --- ------------------------------------------------------------------------------ - -module Xmobar.System.DBus (runIPC) where - -import DBus -import DBus.Client hiding (interfaceName) -import qualified DBus.Client as DC -import Data.Maybe (isNothing) -import Control.Concurrent.STM -import Control.Exception (handle) -import System.IO (stderr, hPutStrLn) -import Control.Monad.IO.Class (liftIO) - -import Xmobar.System.Signal - -busName :: BusName -busName = busName_ "org.Xmobar.Control" - -objectPath :: ObjectPath -objectPath = objectPath_ "/org/Xmobar/Control" - -interfaceName :: InterfaceName -interfaceName = interfaceName_ "org.Xmobar.Control" - -runIPC :: TMVar SignalType -> IO () -runIPC mvst = handle printException exportConnection - where - printException :: ClientError -> IO () - printException = hPutStrLn stderr . clientErrorMessage - exportConnection = do - client <- connectSession - requestName client busName [ nameDoNotQueue ] - export client objectPath defaultInterface - { DC.interfaceName = interfaceName - , DC.interfaceMethods = [ sendSignalMethod mvst ] - } - -sendSignalMethod :: TMVar SignalType -> Method -sendSignalMethod mvst = makeMethod sendSignalName - (signature_ [variantType $ toVariant (undefined :: SignalType)]) - (signature_ []) - sendSignalMethodCall - where - sendSignalName :: MemberName - sendSignalName = memberName_ "SendSignal" - - sendSignalMethodCall :: MethodCall -> DBusR Reply - sendSignalMethodCall mc = liftIO $ - if methodCallMember mc == sendSignalName - then do - let signals :: [Maybe SignalType] - signals = map fromVariant (methodCallBody mc) - mapM_ sendSignal signals - if any isNothing signals - then return ( ReplyError errorInvalidParameters [] ) - else return ( ReplyReturn [] ) - else - return ( ReplyError errorUnknownMethod [] ) - - sendSignal :: Maybe SignalType -> IO () - sendSignal = maybe (return ()) (atomically . putTMVar mvst) diff --git a/src/lib/Xmobar/System/Environment.hs b/src/lib/Xmobar/System/Environment.hs deleted file mode 100644 index 86197db..0000000 --- a/src/lib/Xmobar/System/Environment.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMobar.Environment --- Copyright : (c) William Song --- License : BSD-style (see LICENSE) --- --- Maintainer : Will Song <incertia@incertia.net> --- Stability : stable --- Portability : portable --- --- A function to expand environment variables in strings --- ------------------------------------------------------------------------------ -module Xmobar.System.Environment(expandEnv) where - -import Control.Applicative ((<$>)) -import Data.Maybe (fromMaybe) -import System.Environment (lookupEnv) - -expandEnv :: String -> IO String -expandEnv "" = return "" -expandEnv (c:s) = case c of - '$' -> do - envVar <- fromMaybe "" <$> lookupEnv e - remainder <- expandEnv s' - return $ envVar ++ remainder - where (e, s') = getVar s - getVar "" = ("", "") - getVar ('{':s'') = (takeUntil "}" s'', drop 1 . dropUntil "}" $ s'') - getVar s'' = (takeUntil filterstr s'', dropUntil filterstr s'') - filterstr = ",./? \t;:\"'~`!@#$%^&*()<>-+=\\|" - takeUntil f = takeWhile (not . flip elem f) - dropUntil f = dropWhile (not . flip elem f) - - '\\' -> case s == "" of - True -> return "\\" - False -> do - remainder <- expandEnv $ drop 1 s - return $ escString s ++ remainder - where escString s' = let (cc:_) = s' in - case cc of - 't' -> "\t" - 'n' -> "\n" - '$' -> "$" - _ -> [cc] - - _ -> do - remainder <- expandEnv s - return $ c : remainder diff --git a/src/lib/Xmobar/System/Kbd.hsc b/src/lib/Xmobar/System/Kbd.hsc deleted file mode 100644 index b9e1d57..0000000 --- a/src/lib/Xmobar/System/Kbd.hsc +++ /dev/null @@ -1,321 +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.System.Kbd where - -import Foreign -import Foreign.C.Types -import Foreign.C.String - -import Graphics.X11.Xlib - -#include <X11/XKBlib.h> -#include <X11/extensions/XKB.h> -#include <X11/extensions/XKBstr.h> - --- --- Definition for XkbStaceRec and getKbdLayout taken from --- XMonad.Layout.XKBLayout --- -data XkbStateRec = XkbStateRec { - group :: CUChar, - locked_group :: CUChar, - base_group :: CUShort, - latched_group :: CUShort, - mods :: CUChar, - base_mods :: CUChar, - latched_mods :: CUChar, - locked_mods :: CUChar, - compat_state :: CUChar, - grab_mods :: CUChar, - compat_grab_mods :: CUChar, - lookup_mods :: CUChar, - compat_lookup_mods :: CUChar, - ptr_buttons :: CUShort -} - -instance Storable XkbStateRec where - sizeOf _ = (#size XkbStateRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_group <- (#peek XkbStateRec, group) ptr - r_locked_group <- (#peek XkbStateRec, locked_group) ptr - r_base_group <- (#peek XkbStateRec, base_group) ptr - r_latched_group <- (#peek XkbStateRec, latched_group) ptr - r_mods <- (#peek XkbStateRec, mods) ptr - r_base_mods <- (#peek XkbStateRec, base_mods) ptr - r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr - r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr - r_compat_state <- (#peek XkbStateRec, compat_state) ptr - r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr - r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr - r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr - r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr - r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr - return XkbStateRec { - group = r_group, - locked_group = r_locked_group, - base_group = r_base_group, - latched_group = r_latched_group, - mods = r_mods, - base_mods = r_base_mods, - latched_mods = r_latched_mods, - locked_mods = r_locked_mods, - compat_state = r_compat_state, - grab_mods = r_grab_mods, - compat_grab_mods = r_compat_grab_mods, - lookup_mods = r_lookup_mods, - compat_lookup_mods = r_compat_lookup_mods, - ptr_buttons = r_ptr_buttons - } - -foreign import ccall unsafe "X11/XKBlib.h XkbGetState" - xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt - - -getKbdLayout :: Display -> IO Int -getKbdLayout d = alloca $ \stRecPtr -> do - xkbGetState d 0x100 stRecPtr - st <- peek stRecPtr - return $ fromIntegral (group st) - -data XkbKeyNameRec = XkbKeyNameRec { - name :: Ptr CChar -- array -} - --- --- the t_ before alias is just because of name collisions --- -data XkbKeyAliasRec = XkbKeyAliasRec { - real :: Ptr CChar, -- array - t_alias :: Ptr CChar -- array -} - --- --- the t_ before geometry is just because of name collisions --- -data XkbNamesRec = XkbNamesRec { - keycodes :: Atom, - t_geometry :: Atom, - symbols :: Atom, - types :: Atom, - compat :: Atom, - vmods :: Ptr Atom, - indicators :: Ptr Atom, -- array - groups :: Ptr Atom, -- array - keys :: Ptr XkbKeyNameRec, - key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec, - radio_groups :: Ptr Atom, - phys_symbols :: Atom, - num_keys :: CUChar, - num_key_aliases :: CUChar, - num_rg :: CUShort -} - --- --- the t_ before map, indicators and compat are just because of name collisions --- -data XkbDescRec = XkbDescRec { - t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care - flags :: CUShort, - device_spec :: CUShort, - min_key_code :: KeyCode, - max_key_code :: KeyCode, - ctrls :: Ptr CChar, -- XkbControlsPtr ; dont' care - server :: Ptr CChar, -- XkbServerMapPtr ; dont' care - t_map :: Ptr CChar, --XkbClientMapPtr ; dont' care - t_indicators :: Ptr CChar, -- XkbIndicatorPtr ; dont' care - names :: Ptr XkbNamesRec, -- array - t_compat :: Ptr CChar, -- XkbCompatMap ; dont' care - geom :: Ptr CChar -- XkbGeometryPtr ; dont' care - -} - -instance Storable XkbKeyNameRec where - sizeOf _ = (#size XkbKeyNameRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_name <- (#peek XkbKeyNameRec, name) ptr - - return XkbKeyNameRec { - name = r_name - } - -instance Storable XkbKeyAliasRec where - sizeOf _ = (#size XkbKeyAliasRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_real <- (#peek XkbKeyAliasRec, real) ptr - r_alias <- (#peek XkbKeyAliasRec, alias) ptr - - return XkbKeyAliasRec { - real = r_real, - t_alias = r_alias - } - -instance Storable XkbNamesRec where - sizeOf _ = (#size XkbNamesRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_keycodes <- (#peek XkbNamesRec, keycodes) ptr - r_geometry <- (#peek XkbNamesRec, geometry) ptr - r_symbols <- (#peek XkbNamesRec, symbols ) ptr - r_types <- (#peek XkbNamesRec, types ) ptr - r_compat <- (#peek XkbNamesRec, compat ) ptr - r_vmods <- (#peek XkbNamesRec, vmods ) ptr - r_indicators <- (#peek XkbNamesRec, indicators ) ptr - r_groups <- (#peek XkbNamesRec, groups ) ptr - r_keys <- (#peek XkbNamesRec, keys ) ptr - r_key_aliases <- (#peek XkbNamesRec, key_aliases ) ptr - r_radio_groups <- (#peek XkbNamesRec, radio_groups ) ptr - r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr - r_num_keys <- (#peek XkbNamesRec,num_keys ) ptr - r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases ) ptr - r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr - - return XkbNamesRec { - keycodes = r_keycodes, - t_geometry = r_geometry, - symbols = r_symbols, - types = r_types, - compat = r_compat, - vmods = r_vmods, - indicators = r_indicators, - groups = r_groups, - keys = r_keys, - key_aliases = r_key_aliases, - radio_groups = r_radio_groups, - phys_symbols = r_phys_symbols, - num_keys = r_num_keys, - num_key_aliases = r_num_key_aliases, - num_rg = r_num_rg - } - -instance Storable XkbDescRec where - sizeOf _ = (#size XkbDescRec) - alignment _ = alignment (undefined :: CUShort) - poke _ _ = undefined - peek ptr = do - r_dpy <- (#peek XkbDescRec, dpy) ptr - r_flags <- (#peek XkbDescRec, flags) ptr - r_device_spec <- (#peek XkbDescRec, device_spec) ptr - r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr - r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr - r_ctrls <- (#peek XkbDescRec, ctrls) ptr - r_server <- (#peek XkbDescRec, server) ptr - r_map <- (#peek XkbDescRec, map) ptr - r_indicators <- (#peek XkbDescRec, indicators) ptr - r_names <- (#peek XkbDescRec, names) ptr - r_compat <- (#peek XkbDescRec, compat) ptr - r_geom <- (#peek XkbDescRec, geom) ptr - - return XkbDescRec { - t_dpy = r_dpy, - flags = r_flags, - device_spec = r_device_spec, - min_key_code = r_min_key_code, - max_key_code = r_max_key_code, - ctrls = r_ctrls, - server = r_server, - t_map = r_map, - t_indicators = r_indicators, - names = r_names, - t_compat = r_compat, - geom = r_geom - } - --- --- C bindings --- - -foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard" - xkbAllocKeyboard :: IO (Ptr XkbDescRec) - -foreign import ccall unsafe "X11/XKBlib.h XkbGetNames" - xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec) -> IO Status - -foreign import ccall unsafe "X11/XKBlib.h XGetAtomName" - xGetAtomName :: Display -> Atom -> IO CString - -foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames" - xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () - -foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard" - xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () - -foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails" - xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt - -foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents" - xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt - - -xkbUseCoreKbd :: CUInt -xkbUseCoreKbd = #const XkbUseCoreKbd - -xkbStateNotify :: CUInt -xkbStateNotify = #const XkbStateNotify - -xkbIndicatorStateNotify :: CUInt -xkbIndicatorStateNotify = #const XkbIndicatorStateNotify - -xkbMapNotify :: CUInt -xkbMapNotify = #const XkbMapNotify - -xkbMapNotifyMask :: CUInt -xkbMapNotifyMask = #const XkbMapNotifyMask - -xkbNewKeyboardNotifyMask :: CUInt -xkbNewKeyboardNotifyMask = #const XkbNewKeyboardNotifyMask - -xkbAllStateComponentsMask :: CULong -xkbAllStateComponentsMask = #const XkbAllStateComponentsMask - -xkbGroupStateMask :: CULong -xkbGroupStateMask = #const XkbGroupStateMask - -xkbSymbolsNameMask :: CUInt -xkbSymbolsNameMask = #const XkbSymbolsNameMask - -xkbGroupNamesMask :: CUInt -xkbGroupNamesMask = #const XkbGroupNamesMask - -type KbdOpts = [(String, String)] - -getLayoutStr :: Display -> IO String -getLayoutStr dpy = do - kbdDescPtr <- xkbAllocKeyboard - status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr - str <- getLayoutStr' status dpy kbdDescPtr - xkbFreeNames kbdDescPtr xkbGroupNamesMask 1 - xkbFreeKeyboard kbdDescPtr 0 1 - return str - -getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String -getLayoutStr' st dpy kbdDescPtr = - if st == 0 then -- Success - do - kbdDesc <- peek kbdDescPtr - nameArray <- peek (names kbdDesc) - atom <- xGetAtomName dpy (symbols nameArray) - str <- peekCString atom - return str - else -- Behaviour on error - do - return "Error while requesting layout!" diff --git a/src/lib/Xmobar/System/Localize.hsc b/src/lib/Xmobar/System/Localize.hsc deleted file mode 100644 index eec5e3b..0000000 --- a/src/lib/Xmobar/System/Localize.hsc +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Localize --- Copyright : (C) 2011, 2018 Martin Perner --- License : BSD-style (see LICENSE) --- --- Maintainer : Martin Perner <martin@perner.cc> --- Stability : unstable --- Portability : unportable --- --- This module provides an interface to locale information e.g. for DateL --- ------------------------------------------------------------------------------ - -module Xmobar.System.Localize - ( setupTimeLocale, - getTimeLocale - ) where - -import Foreign.C -#if ! MIN_VERSION_time(1,5,0) -import qualified System.Locale as L -#else -import qualified Data.Time.Format as L -#endif - -#ifdef UTF8 -import Codec.Binary.UTF8.String -#endif - --- get localized strings -type NlItem = CInt - -#include <langinfo.h> -foreign import ccall unsafe "langinfo.h nl_langinfo" - nl_langinfo :: NlItem -> IO CString - -#{enum NlItem, - , AM_STR , PM_STR \ - , D_T_FMT , D_FMT , T_FMT , T_FMT_AMPM \ - , ABDAY_1, ABDAY_7 \ - , DAY_1, DAY_7 \ - , ABMON_1, ABMON_12 \ - , MON_1, MON_12\ - } - -getLangInfo :: NlItem -> IO String -getLangInfo item = do - itemStr <- nl_langinfo item -#ifdef UTF8 - str <- peekCString itemStr - return $ if isUTF8Encoded str then decodeString str else str -#else - peekCString itemStr -#endif - -#include <locale.h> -foreign import ccall unsafe "locale.h setlocale" - setlocale :: CInt -> CString -> IO CString - -setupTimeLocale :: String -> IO () -setupTimeLocale l = withCString l (setlocale #const LC_TIME) >> return () - -getTimeLocale :: IO L.TimeLocale -getTimeLocale = do - -- assumes that the defined values are increasing by exactly one. - -- as they are defined consecutive in an enum this is reasonable - days <- mapM getLangInfo [day1 .. day7] - abdays <- mapM getLangInfo [abday1 .. abday7] - - mons <- mapM getLangInfo [mon1 .. mon12] - abmons <- mapM getLangInfo [abmon1 .. abmon12] - - amstr <- getLangInfo amStr - pmstr <- getLangInfo pmStr - dtfmt <- getLangInfo dTFmt - dfmt <- getLangInfo dFmt - tfmt <- getLangInfo tFmt - tfmta <- getLangInfo tFmtAmpm - - let t = L.defaultTimeLocale {L.wDays = zip days abdays - ,L.months = zip mons abmons - ,L.amPm = (amstr, pmstr) - ,L.dateTimeFmt = dtfmt - ,L.dateFmt = dfmt - ,L.timeFmt = tfmt - ,L.time12Fmt = tfmta} - return t diff --git a/src/lib/Xmobar/System/Signal.hs b/src/lib/Xmobar/System/Signal.hs deleted file mode 100644 index ce39e10..0000000 --- a/src/lib/Xmobar/System/Signal.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Signal --- Copyright : (c) Andrea Rosatto --- : (c) Jose A. Ortega Ruiz --- : (c) Jochen Keil --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Signal handling, including DBUS when available --- ------------------------------------------------------------------------------ - -module Xmobar.System.Signal where - -import Data.Foldable (for_) -import Data.Typeable (Typeable) -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import System.Posix.Signals -import Graphics.X11.Types (Button) -import Graphics.X11.Xlib.Types (Position) -import System.IO - -#ifdef DBUS -import DBus (IsVariant(..)) -import Control.Monad ((>=>)) -#endif - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x - -data WakeUp = WakeUp deriving (Show,Typeable) -instance Exception WakeUp - -data SignalType = Wakeup - | Reposition - | ChangeScreen - | Hide Int - | Reveal Int - | Toggle Int - | TogglePersistent - | Action Button Position - deriving (Read, Show) - -#ifdef DBUS -instance IsVariant SignalType where - toVariant = toVariant . show - fromVariant = fromVariant >=> parseSignalType -#endif - -parseSignalType :: String -> Maybe SignalType -parseSignalType = fmap fst . safeHead . reads - --- | Signal handling -setupSignalHandler :: IO (TMVar SignalType) -setupSignalHandler = do - tid <- newEmptyTMVarIO - installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing - installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing - return tid - -updatePosHandler :: TMVar SignalType -> IO () -updatePosHandler sig = do - atomically $ putTMVar sig Reposition - return () - -changeScreenHandler :: TMVar SignalType -> IO () -changeScreenHandler sig = do - atomically $ putTMVar sig ChangeScreen - return () - - --- | Ensures that the given IO action runs its cleanup actions ('bracket' etc.), --- even if a signal is caught. --- --- An exception will be thrown on the thread that called this function when a --- signal is caught. -withDeferSignals :: IO a -> IO a -withDeferSignals thing = do - threadId <- myThreadId - caughtSignal <- newEmptyMVar - - let signals = - filter (not . flip inSignalSet reservedSignals) - [ sigQUIT - , sigTERM - --, sigINT -- Handler already installed by GHC - --, sigPIPE -- Handler already installed by GHC - --, sigUSR1 -- Handled by setupSignalHandler - --, sigUSR2 -- Handled by setupSignalHandler - - -- One of the following appears to cause instability, see #360 - --, sigHUP - --, sigILL - --, sigABRT - --, sigFPE - --, sigSEGV - --, sigALRM - --, sigBUS - --, sigPOLL - --, sigPROF - --, sigSYS - --, sigTRAP - --, sigVTALRM - --, sigXCPU - --, sigXFSZ - ] - - for_ signals $ \s -> - - installHandler s - (Catch $ do - tryPutMVar caughtSignal s - hPutStrLn stderr ("xmobar: Caught signal "++show s++"; exiting...") - throwTo threadId ThreadKilled) - Nothing - - thing `finally` do - s0 <- tryReadMVar caughtSignal - case s0 of - Nothing -> pure () - Just s -> do - -- Run the default handler for the signal - -- hPutStrLn stderr ("xmobar: Running default handler for signal "++show s) - installHandler s Default Nothing - raiseSignal s diff --git a/src/lib/Xmobar/System/StatFS.hsc b/src/lib/Xmobar/System/StatFS.hsc deleted file mode 100644 index 529b16a..0000000 --- a/src/lib/Xmobar/System/StatFS.hsc +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : StatFS --- Copyright : (c) Jose A Ortega Ruiz --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- A binding to C's statvfs(2) --- ------------------------------------------------------------------------------ - -{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} - - -module Xmobar.System.StatFS ( FileSystemStats(..), getFileSystemStats ) where - -import Foreign -import Foreign.C.Types -import Foreign.C.String -import Data.ByteString (useAsCString) -import Data.ByteString.Char8 (pack) - -#if defined (__FreeBSD__) || defined (__OpenBSD__) || defined (__APPLE__) || defined (__DragonFly__) -#define IS_BSD_SYSTEM -#endif - -#ifdef IS_BSD_SYSTEM -# include <sys/param.h> -# include <sys/mount.h> -#else -# include <sys/vfs.h> -#endif - -data FileSystemStats = FileSystemStats { - fsStatBlockSize :: Integer - -- ^ Optimal transfer block size. - , fsStatBlockCount :: Integer - -- ^ Total data blocks in file system. - , fsStatByteCount :: Integer - -- ^ Total bytes in file system. - , fsStatBytesFree :: Integer - -- ^ Free bytes in file system. - , fsStatBytesAvailable :: Integer - -- ^ Free bytes available to non-superusers. - , fsStatBytesUsed :: Integer - -- ^ Bytes used. - } deriving (Show, Eq) - -data CStatfs - -#ifdef IS_BSD_SYSTEM -foreign import ccall unsafe "sys/mount.h statfs" -#else -foreign import ccall unsafe "sys/vfs.h statvfs" -#endif - c_statfs :: CString -> Ptr CStatfs -> IO CInt - -toI :: CULong -> Integer -toI = toInteger - -getFileSystemStats :: String -> IO (Maybe FileSystemStats) -getFileSystemStats path = - allocaBytes (#size struct statfs) $ \vfs -> - useAsCString (pack path) $ \cpath -> do - res <- c_statfs cpath vfs - if res /= 0 then return Nothing - else do - bsize <- (#peek struct statfs, f_bsize) vfs - bcount <- (#peek struct statfs, f_blocks) vfs - bfree <- (#peek struct statfs, f_bfree) vfs - bavail <- (#peek struct statfs, f_bavail) vfs - let bpb = toI bsize - return $ Just FileSystemStats - { fsStatBlockSize = bpb - , fsStatBlockCount = toI bcount - , fsStatByteCount = toI bcount * bpb - , fsStatBytesFree = toI bfree * bpb - , fsStatBytesAvailable = toI bavail * bpb - , fsStatBytesUsed = toI (bcount - bfree) * bpb - } diff --git a/src/lib/Xmobar/Utils.hs b/src/lib/Xmobar/Utils.hs deleted file mode 100644 index a2da606..0000000 --- a/src/lib/Xmobar/Utils.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- --- | --- Module: Utils --- Copyright: (c) 2010, 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: Jose A Ortega Ruiz <jao@gnu.org> --- Stability: unstable --- Portability: unportable --- Created: Sat Dec 11, 2010 20:55 --- --- --- Miscellaneous utility functions --- ------------------------------------------------------------------------------- - - -module Xmobar.Utils - (expandHome, changeLoop, hGetLineSafe, nextEvent', tenthSeconds) -where - -import Control.Monad -import Control.Concurrent -import Control.Concurrent.STM -import System.Posix.Types (Fd(..)) - -import System.Environment -import System.FilePath -import System.IO - -import Graphics.X11.Xlib ( - Display(..), XEventPtr, nextEvent, pending, connectionNumber) - -#if defined XFT || defined UTF8 -import qualified System.IO as S (hGetLine) -#endif - -hGetLineSafe :: Handle -> IO String -#if defined XFT || defined UTF8 -hGetLineSafe = S.hGetLine -#else -hGetLineSafe = hGetLine -#endif - - -expandHome :: FilePath -> IO FilePath -expandHome ('~':'/':path) = fmap (</> path) (getEnv "HOME") -expandHome p = return p - -changeLoop :: Eq a => STM a -> (a -> IO ()) -> IO () -changeLoop s f = atomically s >>= go - where - go old = do - f old - go =<< atomically (do - new <- s - guard (new /= old) - return new) - --- | A version of nextEvent that does not block in foreign calls. -nextEvent' :: Display -> XEventPtr -> IO () -nextEvent' d p = do - pend <- pending d - if pend /= 0 - then nextEvent d p - else do - threadWaitRead (Fd fd) - nextEvent' d p - where - fd = connectionNumber d - - --- | Work around to the Int max bound: since threadDelay takes an Int, it --- is not possible to set a thread delay grater than about 45 minutes. --- With a little recursion we solve the problem. -tenthSeconds :: Int -> IO () -tenthSeconds s | s >= x = do threadDelay (x * 100000) - tenthSeconds (s - x) - | otherwise = threadDelay (s * 100000) - where x = (maxBound :: Int) `div` 100000 diff --git a/src/lib/Xmobar/X11/Bitmap.hs b/src/lib/Xmobar/X11/Bitmap.hs deleted file mode 100644 index c0dba14..0000000 --- a/src/lib/Xmobar/X11/Bitmap.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : X11.Bitmap --- Copyright : (C) 2013, 2015, 2017, 2018 Alexander Polakov --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.X11.Bitmap - ( updateCache - , drawBitmap - , Bitmap(..)) where - -import Control.Monad -import Control.Monad.Trans(MonadIO(..)) -import Data.Map hiding (map, filter) -import Graphics.X11.Xlib -import System.Directory (doesFileExist) -import System.FilePath ((</>)) -import System.Mem.Weak ( addFinalizer ) -import Xmobar.X11.ColorCache -import Xmobar.X11.Parsers (Widget(..)) -import Xmobar.Actions (Action) - -#ifdef XPM -import Xmobar.X11.XPMFile(readXPMFile) -import Control.Applicative((<|>)) -#endif - -#if MIN_VERSION_mtl(2, 2, 1) -import Control.Monad.Except(MonadError(..), runExceptT) - -#else -import Control.Monad.Error(MonadError(..)) -import Control.Monad.Trans.Error(ErrorT, runErrorT) - -runExceptT :: ErrorT e m a -> m (Either e a) -runExceptT = runErrorT - -#endif - -data BitmapType = Mono Pixel | Poly - -data Bitmap = Bitmap { width :: Dimension - , height :: Dimension - , pixmap :: Pixmap - , shapePixmap :: Maybe Pixmap - , bitmapType :: BitmapType - } - -updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> - [[(Widget, String, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap) -updateCache dpy win cache iconRoot ps = do - let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps - icons (Icon _, _, _, _) = True - icons _ = False - expandPath path@('/':_) = path - expandPath path@('.':'/':_) = path - expandPath path@('.':'.':'/':_) = path - expandPath path = iconRoot </> path - go m path = if member path m - then return m - else do bitmap <- loadBitmap dpy win $ expandPath path - return $ maybe m (\b -> insert path b m) bitmap - foldM go cache paths - -readBitmapFile' - :: (MonadError String m, MonadIO m) - => Display - -> Drawable - -> String - -> m (Dimension, Dimension, Pixmap) -readBitmapFile' d w p = do - res <- liftIO $ readBitmapFile d w p - case res of - Left err -> throwError err - Right (bw, bh, bp, _, _) -> return (bw, bh, bp) - -loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap) -loadBitmap d w p = do - exist <- doesFileExist p - if exist - then do -#ifdef XPM - res <- runExceptT (tryXBM <|> tryXPM) -#else - res <- runExceptT tryXBM -#endif - case res of - Right b -> return $ Just b - Left err -> do - putStrLn err - return Nothing - else - return Nothing - where tryXBM = do - (bw, bh, bp) <- readBitmapFile' d w p - liftIO $ addFinalizer bp (freePixmap d bp) - return $ Bitmap bw bh bp Nothing (Mono 1) -#ifdef XPM - tryXPM = do - (bw, bh, bp, mbpm) <- readXPMFile d w p - liftIO $ addFinalizer bp (freePixmap d bp) - case mbpm of - Nothing -> return () - Just bpm -> liftIO $ addFinalizer bpm (freePixmap d bpm) - return $ Bitmap bw bh bp mbpm Poly -#endif - -drawBitmap :: Display -> Drawable -> GC -> String -> String - -> Position -> Position -> Bitmap -> IO () -drawBitmap d p gc fc bc x y i = - withColors d [fc, bc] $ \[fc', bc'] -> do - let w = width i - h = height i - y' = 1 + y - fromIntegral h `div` 2 - setForeground d gc fc' - setBackground d gc bc' - case shapePixmap i of - Nothing -> return () - Just mask -> setClipOrigin d gc x y' >> setClipMask d gc mask - case bitmapType i of - Poly -> copyArea d (pixmap i) p gc 0 0 w h x y' - Mono pl -> copyPlane d (pixmap i) p gc 0 0 w h x y' pl - setClipMask d gc 0 diff --git a/src/lib/Xmobar/X11/ColorCache.hs b/src/lib/Xmobar/X11/ColorCache.hs deleted file mode 100644 index 4d22e16..0000000 --- a/src/lib/Xmobar/X11/ColorCache.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- --- | --- Module: ColorCache --- Copyright: (c) 2012 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Created: Mon Sep 10, 2012 00:27 --- --- --- Caching X colors --- ------------------------------------------------------------------------------- - -#if defined XFT - -module Xmobar.X11.ColorCache(withColors, withDrawingColors) where - -import Xmobar.X11.MinXft - -#else - -module Xmobar.X11.ColorCache(withColors) where - -#endif - -import Data.IORef -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Exception (SomeException, handle) -import Graphics.X11.Xlib - -data DynPixel = DynPixel Bool Pixel - -initColor :: Display -> String -> IO DynPixel -initColor dpy c = handle black $ initColor' dpy c - where - black :: SomeException -> IO DynPixel - black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy) - -type ColorCache = [(String, Color)] -{-# NOINLINE colorCache #-} -colorCache :: IORef ColorCache -colorCache = unsafePerformIO $ newIORef [] - -getCachedColor :: String -> IO (Maybe Color) -getCachedColor color_name = lookup color_name `fmap` readIORef colorCache - -putCachedColor :: String -> Color -> IO () -putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c - -initColor' :: Display -> String -> IO DynPixel -initColor' dpy c = do - let colormap = defaultColormap dpy (defaultScreen dpy) - cached_color <- getCachedColor c - c' <- case cached_color of - Just col -> return col - _ -> do (c'', _) <- allocNamedColor dpy colormap c - putCachedColor c c'' - return c'' - return $ DynPixel True (color_pixel c') - -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a -withColors d cs f = do - ps <- mapM (liftIO . initColor d) cs - f $ map (\(DynPixel _ pixel) -> pixel) ps - -#ifdef XFT - -type AXftColorCache = [(String, AXftColor)] -{-# NOINLINE xftColorCache #-} -xftColorCache :: IORef AXftColorCache -xftColorCache = unsafePerformIO $ newIORef [] - -getXftCachedColor :: String -> IO (Maybe AXftColor) -getXftCachedColor name = lookup name `fmap` readIORef xftColorCache - -putXftCachedColor :: String -> AXftColor -> IO () -putXftCachedColor name cptr = - modifyIORef xftColorCache $ \c -> (name, cptr) : c - -initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor -initAXftColor' d v cm c = do - cc <- getXftCachedColor c - c' <- case cc of - Just col -> return col - _ -> do c'' <- mallocAXftColor d v cm c - putXftCachedColor c c'' - return c'' - return c' - -initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor -initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) - where - black :: SomeException -> IO AXftColor - black = (const $ initAXftColor' d v cm "black") - -withDrawingColors :: -- MonadIO m => - Display -> Drawable -> String -> String - -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () -withDrawingColors dpy drw fc bc f = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen - fc' <- initAXftColor dpy visual colormap fc - bc' <- initAXftColor dpy visual colormap bc - withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' -#endif diff --git a/src/lib/Xmobar/X11/Draw.hs b/src/lib/Xmobar/X11/Draw.hs deleted file mode 100644 index d0c78a8..0000000 --- a/src/lib/Xmobar/X11/Draw.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- --- | --- Module: Xmobar.X11.Draw --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 18:49 --- --- --- Drawing the xmobar contents --- ------------------------------------------------------------------------------- - - -module Xmobar.X11.Draw (drawInWin) where - -import Prelude hiding (lookup) -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad (when) -import Control.Arrow ((&&&)) -import Data.Map hiding (foldr, map, filter) - -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import Graphics.X11.Xlib.Extras - -import Xmobar.Actions (Action(..)) -import qualified Xmobar.X11.Bitmap as B -import Xmobar.X11.Types -import Xmobar.X11.XUtil -import Xmobar.Config -import Xmobar.X11.ColorCache -import Xmobar.X11.Window (drawBorder) -import Xmobar.X11.Parsers (Widget(..)) - -#ifdef XFT -import Xmobar.X11.MinXft -import Graphics.X11.Xrender -#endif - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - --- | Draws in and updates the window -drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X () -drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do - r <- ask - let (c,d) = (config &&& display) r - (w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r - strLn = liftIO . mapM getWidth - iconW i = maybe 0 B.width (lookup i $ iconS r) - getWidth (Text s,cl,i,_) = - textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw) - getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) - - p <- liftIO $ createPixmap d w wid ht - (defaultDepthOfScreen (defaultScreenOfDisplay d)) -#if XFT - when (alpha c /= 255) (liftIO $ drawBackground d p (bgColor c) (alpha c) wr) -#endif - withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do - gc <- liftIO $ createGC d w -#if XFT - when (alpha c == 255) $ do -#else - do -#endif - liftIO $ setForeground d gc bgcolor - liftIO $ fillRectangle d p gc 0 0 wid ht - -- write to the pixmap the new string - printStrings p gc fs vs 1 L =<< strLn left - printStrings p gc fs vs 1 R =<< strLn right - printStrings p gc fs vs 1 C =<< strLn center - -- draw border if requested - liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht - -- copy the pixmap with the new string to the window - liftIO $ copyArea d p w gc 0 0 wid ht 0 0 - -- free up everything (we do not want to leak memory!) - liftIO $ freeGC d gc - liftIO $ freePixmap d p - -- resync - liftIO $ sync d True - -verticalOffset :: (Integral b, Integral a, MonadIO m) => - a -> Widget -> XFont -> Int -> Config -> m b -verticalOffset ht (Text t) fontst voffs _ - | voffs > -1 = return $ fi voffs - | otherwise = do - (as,ds) <- liftIO $ textExtents fontst t - let margin = (fi ht - fi ds - fi as) `div` 2 - return $ fi as + margin - 1 -verticalOffset ht (Icon _) _ _ conf - | iconOffset conf > -1 = return $ fi (iconOffset conf) - | otherwise = return $ fi (ht `div` 2) - 1 - -printString :: Display -> Drawable -> XFont -> GC -> String -> String - -> Position -> Position -> String -> Int -> IO () -printString d p (Core fs) gc fc bc x y s a = do - setFont d gc $ fontFromFontStruct fs - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - when (a == 255) (setBackground d gc bc') - drawImageString d p gc x y s - -printString d p (Utf8 fs) gc fc bc x y s a = - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - when (a == 255) (setBackground d gc bc') - liftIO $ wcDrawImageString d p fs gc x y s - -#ifdef XFT -printString dpy drw fs@(Xft fonts) _ fc bc x y s al = - withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do - when (al == 255) $ do - (a,d) <- textExtents fs s - gi <- xftTxtExtents' dpy fonts s - drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) - drawXftString' draw fc' fonts (toInteger x) (toInteger y) s -#endif - --- | An easy way to print the stuff we need to print -printStrings :: Drawable -> GC -> [XFont] -> [Int] -> Position - -> Align -> [(Widget, String, Int, Position)] -> X () -printStrings _ _ _ _ _ _ [] = return () -printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do - r <- ask - let (conf,d) = (config &&& display) r - alph = alpha conf - Rectangle _ _ wid ht = rect r - totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl - remWidth = fi wid - fi totSLen - fontst = fontlist !! i - offset = case a of - C -> (remWidth + offs) `div` 2 - R -> remWidth - L -> offs - (fc,bc) = case break (==',') c of - (f,',':b) -> (f, b ) - (f, _) -> (f, bgColor conf) - valign <- verticalOffset ht s (head fontlist) (voffs !! i) conf - case s of - (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph - (Icon p) -> liftIO $ maybe (return ()) - (B.drawBitmap d dr gc fc bc offset valign) - (lookup p (iconS r)) - printStrings dr gc fontlist voffs (offs + l) a xs diff --git a/src/lib/Xmobar/X11/MinXft.hsc b/src/lib/Xmobar/X11/MinXft.hsc deleted file mode 100644 index e593da0..0000000 --- a/src/lib/Xmobar/X11/MinXft.hsc +++ /dev/null @@ -1,333 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: MinXft --- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz --- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007 --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Created: Mon Sep 10, 2012 18:12 --- --- --- Pared down Xft library, based on Graphics.X11.Xft and providing --- explicit management of XftColors, so that they can be cached. --- --- Most of the code is lifted from Clemens's. --- ------------------------------------------------------------------------------- - -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} - -module Xmobar.X11.MinXft ( AXftColor - , AXftDraw (..) - , AXftFont - , mallocAXftColor - , freeAXftColor - , withAXftDraw - , drawXftString - , drawXftString' - , drawBackground - , drawXftRect - , openAXftFont - , closeAXftFont - , xftTxtExtents - , xftTxtExtents' - , xft_ascent - , xft_ascent' - , xft_descent - , xft_descent' - , xft_height - , xft_height' - ) - -where - -import Graphics.X11 -import Graphics.X11.Xlib.Types -import Graphics.X11.Xrender -import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree) - -import Foreign -import Foreign.C.Types -import Foreign.C.String -import Codec.Binary.UTF8.String as UTF8 -import Data.Char (ord) - -import Control.Monad (when) - -#include <X11/Xft/Xft.h> - --- Color Handling - -newtype AXftColor = AXftColor (Ptr AXftColor) - -foreign import ccall "XftColorAllocName" - cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool) - --- this is the missing bit in X11.Xft, not implementable from the --- outside because XftColor does not export a constructor. -mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor -mallocAXftColor d v cm n = do - color <- mallocBytes (#size XftColor) - withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color) - return (AXftColor color) - -foreign import ccall "XftColorFree" - freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO () - --- Font handling - -newtype AXftFont = AXftFont (Ptr AXftFont) - -xft_ascent :: AXftFont -> IO Int -xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent} - -xft_ascent' :: [AXftFont] -> IO Int -xft_ascent' = (fmap maximum) . (mapM xft_ascent) - -xft_descent :: AXftFont -> IO Int -xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent} - -xft_descent' :: [AXftFont] -> IO Int -xft_descent' = (fmap maximum) . (mapM xft_descent) - -xft_height :: AXftFont -> IO Int -xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height} - -xft_height' :: [AXftFont] -> IO Int -xft_height' = (fmap maximum) . (mapM xft_height) - -foreign import ccall "XftTextExtentsUtf8" - cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO () - -xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo -xftTxtExtents d f string = - withArrayLen (map fi (UTF8.encode string)) $ - \len str_ptr -> alloca $ - \cglyph -> do - cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph - peek cglyph - -xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo -xftTxtExtents' d fs string = do - chunks <- getChunks d fs string - let (_, _, gi, _, _) = last chunks - return gi - -foreign import ccall "XftFontOpenName" - c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont - -openAXftFont :: Display -> Screen -> String -> IO AXftFont -openAXftFont dpy screen name = - withCAString name $ - \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname - -foreign import ccall "XftFontClose" - closeAXftFont :: Display -> AXftFont -> IO () - -foreign import ccall "XftCharExists" - cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool) - -xftCharExists :: Display -> AXftFont -> Char -> IO Bool -xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c) - where - bool 0 = False - bool _ = True --- Drawing - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -newtype AXftDraw = AXftDraw (Ptr AXftDraw) - -foreign import ccall "XftDrawCreate" - c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw - -foreign import ccall "XftDrawDisplay" - c_xftDrawDisplay :: AXftDraw -> IO Display - -foreign import ccall "XftDrawDestroy" - c_xftDrawDestroy :: AXftDraw -> IO () - -withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a -withAXftDraw d p v c act = do - draw <- c_xftDrawCreate d p v c - a <- act draw - c_xftDrawDestroy draw - return a - -foreign import ccall "XftDrawStringUtf8" - cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO () - -drawXftString :: (Integral a1, Integral a) => - AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO () -drawXftString d c f x y string = - withArrayLen (map fi (UTF8.encode string)) - (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len)) - -drawXftString' :: AXftDraw -> - AXftColor -> - [AXftFont] -> - Integer -> - Integer -> - String -> IO () -drawXftString' d c fs x y string = do - display <- c_xftDrawDisplay d - chunks <- getChunks display fs string - mapM_ (\(f, s, _, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks - --- Split string and determine fonts/offsets for individual parts -getChunks :: Display -> [AXftFont] -> String -> - IO [(AXftFont, String, XGlyphInfo, Integer, Integer)] -getChunks disp fts str = do - chunks <- getFonts disp fts str - getOffsets (XGlyphInfo 0 0 0 0 0 0) chunks - where - -- Split string and determine fonts for individual parts - getFonts _ [] _ = return [] - getFonts _ _ [] = return [] - getFonts _ [ft] s = return [(ft, s)] - getFonts d fonts@(ft:_) s = do - -- Determine which glyph can be rendered by current font - glyphs <- mapM (xftCharExists d ft) s - -- Split string into parts that can/cannot be rendered - let splits = split (runs glyphs) s - -- Determine which font to render each chunk with - concat `fmap` mapM (getFont d fonts) splits - - -- Determine fonts for substrings - getFont _ [] _ = return [] - getFont _ [ft] (_, s) = return [(ft, s)] -- Last font, use it - getFont _ (ft:_) (True, s) = return [(ft, s)] -- Current font can render this substring - getFont d (_:fs) (False, s) = getFonts d fs s -- Fallback to next font - - -- Helpers - runs [] = [] - runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t - split [] _ = [] - split ((x, c):xs) s = let (h, t) = splitAt c s in (x, h) : split xs t - - -- Determine coordinates for chunks using extents - getOffsets _ [] = return [] - getOffsets (XGlyphInfo _ _ x y xo yo) ((f, s):chunks) = do - (XGlyphInfo w' h' _ _ xo' yo') <- xftTxtExtents disp f s - let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo') - rest <- getOffsets gi chunks - return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : rest - -foreign import ccall "XftDrawRect" - cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO () - -drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) => - AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO () -drawXftRect draw color x y width height = - cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height) - -#include <X11/extensions/Xrender.h> - -type Picture = XID -type PictOp = CInt - -data XRenderPictFormat -data XRenderPictureAttributes = XRenderPictureAttributes - --- foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle" - -- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO () -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite" - xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO () -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill" - xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture" - xRenderFreePicture :: Display -> Picture -> IO () -foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat" - xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat) -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture" - xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture - - --- Attributes not supported -instance Storable XRenderPictureAttributes where - sizeOf _ = #{size XRenderPictureAttributes} - alignment _ = alignment (undefined :: CInt) - peek _ = return XRenderPictureAttributes - poke p XRenderPictureAttributes = - memset p 0 #{size XRenderPictureAttributes} - --- | Convenience function, gives us an XRender handle to a traditional --- Pixmap. Don't let it escape. -withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO () -withRenderPicture d p f = do - format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24 - alloca $ \attr -> do - pic <- xRenderCreatePicture d p format 0 attr - f pic - xRenderFreePicture d pic - --- | Convenience function, gives us an XRender picture that is a solid --- fill of color 'c'. Don't let it escape. -withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO () -withRenderFill d c f = do - pic <- with c (xRenderCreateSolidFill d) - f pic - xRenderFreePicture d pic - --- | Drawing the background to a pixmap and taking into account --- transparency -drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO () -drawBackground d p bgc alpha (Rectangle x y wid ht) = do - let render opt bg pic m = - xRenderComposite d opt bg m pic - (fromIntegral x) (fromIntegral y) 0 0 - 0 0 (fromIntegral wid) (fromIntegral ht) - withRenderPicture d p $ \pic -> do - -- Handle background color - bgcolor <- parseRenderColor d bgc - withRenderFill d bgcolor $ \bgfill -> - withRenderFill d - (XRenderColor 0 0 0 (257 * alpha)) - (render pictOpSrc bgfill pic) - -- Handle transparency - internAtom d "_XROOTPMAP_ID" False >>= \xid -> - let xroot = defaultRootWindow d in - alloca $ \x1 -> - alloca $ \x2 -> - alloca $ \x3 -> - alloca $ \x4 -> - alloca $ \pprop -> do - xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop - prop <- peek pprop - when (prop /= nullPtr) $ do - rootbg <- peek (castPtr prop) :: IO Pixmap - xFree prop - withRenderPicture d rootbg $ \bgpic -> - withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha)) - (render pictOpAdd bgpic pic) - --- | Parses color into XRender color (allocation not necessary!) -parseRenderColor :: Display -> String -> IO XRenderColor -parseRenderColor d c = do - let colormap = defaultColormap d (defaultScreen d) - Color _ red green blue _ <- parseColor d colormap c - return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF - -pictOpSrc, pictOpAdd :: PictOp -pictOpSrc = 1 -pictOpAdd = 12 - --- pictOpMinimum = 0 --- pictOpClear = 0 --- pictOpDst = 2 --- pictOpOver = 3 --- pictOpOverReverse = 4 --- pictOpIn = 5 --- pictOpInReverse = 6 --- pictOpOut = 7 --- pictOpOutReverse = 8 --- pictOpAtop = 9 --- pictOpAtopReverse = 10 --- pictOpXor = 11 --- pictOpSaturate = 13 --- pictOpMaximum = 13 diff --git a/src/lib/Xmobar/X11/Parsers.hs b/src/lib/Xmobar/X11/Parsers.hs deleted file mode 100644 index 8c1abac..0000000 --- a/src/lib/Xmobar/X11/Parsers.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Parsing for template substrings --- ------------------------------------------------------------------------------ - -module Xmobar.X11.Parsers (parseString, Widget(..)) where - -import Xmobar.Config -import Xmobar.Actions - -import Control.Monad (guard, mzero) -import Text.ParserCombinators.Parsec -import Graphics.X11.Types (Button) - -data Widget = Icon String | Text String - -type ColorString = String -type FontIndex = Int - --- | Runs the string parser -parseString :: Config -> String - -> IO [(Widget, ColorString, FontIndex, Maybe [Action])] -parseString c s = - case parse (stringParser (fgColor c) 0 Nothing) "" s of - Left _ -> return [(Text $ "Could not parse string: " ++ s - , fgColor c - , 0 - , Nothing)] - Right x -> return (concat x) - -allParsers :: ColorString - -> FontIndex - -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -allParsers c f a = textParser c f a - <|> try (iconParser c f a) - <|> try (rawParser c f a) - <|> try (actionParser c f a) - <|> try (fontParser c a) - <|> colorParser f a - --- | Gets the string and combines the needed parsers -stringParser :: String -> FontIndex -> Maybe [Action] - -> Parser [[(Widget, ColorString, FontIndex, Maybe [Action])]] -stringParser c f a = manyTill (allParsers c f a) eof - --- | Parses a maximal string without color markup. -textParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -textParser c f a = do s <- many1 $ - noneOf "<" <|> - try (notFollowedBy' (char '<') - (try (string "fc=") <|> - try (string "fn=") <|> - try (string "action=") <|> - try (string "/action>") <|> - try (string "icon=") <|> - try (string "raw=") <|> - try (string "/fn>") <|> - string "/fc>")) - return [(Text s, c, f, a)] - --- | Parse a "raw" tag, which we use to prevent other tags from creeping in. --- The format here is net-string-esque: a literal "<raw=" followed by a --- string of digits (base 10) denoting the length of the raw string, --- a literal ":" as digit-string-terminator, the raw string itself, and --- then a literal "/>". -rawParser :: ColorString - -> FontIndex - -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -rawParser c f a = do - string "<raw=" - lenstr <- many1 digit - char ':' - case reads lenstr of - [(len,[])] -> do - guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) - s <- count (fromIntegral len) anyChar - string "/>" - return [(Text s, c, f, a)] - _ -> mzero - --- | Wrapper for notFollowedBy that returns the result of the first parser. --- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy --- accepts only parsers with return type Char. -notFollowedBy' :: Parser a -> Parser b -> Parser a -notFollowedBy' p e = do x <- p - notFollowedBy $ try (e >> return '*') - return x - -iconParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -iconParser c f a = do - string "<icon=" - i <- manyTill (noneOf ">") (try (string "/>")) - return [(Icon i, c, f, a)] - -actionParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -actionParser c f act = do - string "<action=" - command <- choice [between (char '`') (char '`') (many1 (noneOf "`")), - many1 (noneOf ">")] - buttons <- (char '>' >> return "1") <|> (space >> spaces >> - between (string "button=") (string ">") (many1 (oneOf "12345"))) - let a = Spawn (toButtons buttons) command - a' = case act of - Nothing -> Just [a] - Just act' -> Just $ a : act' - s <- manyTill (allParsers c f a') (try $ string "</action>") - return (concat s) - -toButtons :: String -> [Button] -toButtons = map (\x -> read [x]) - --- | Parsers a string wrapped in a color specification. -colorParser :: FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -colorParser f a = do - c <- between (string "<fc=") (string ">") colors - s <- manyTill (allParsers c f a) (try $ string "</fc>") - return (concat s) - --- | Parsers a string wrapped in a font specification. -fontParser :: ColorString -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -fontParser c a = do - f <- between (string "<fn=") (string ">") colors - s <- manyTill (allParsers c (read f) a) (try $ string "</fn>") - return (concat s) - --- | Parses a color specification (hex or named) -colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char '#') diff --git a/src/lib/Xmobar/X11/Types.hs b/src/lib/Xmobar/X11/Types.hs deleted file mode 100644 index c5c7ade..0000000 --- a/src/lib/Xmobar/X11/Types.hs +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Xmobar.Types --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 19:02 --- --- --- The Xmobar basic type --- ------------------------------------------------------------------------------- - - -module Xmobar.X11.Types (X, XConf (..)) where - -import Graphics.X11.Xlib -import Control.Monad.Reader -import Data.Map - -import Xmobar.X11.Bitmap -import Xmobar.X11.XUtil -import Xmobar.Config - --- | The X type is a ReaderT -type X = ReaderT XConf IO - --- | The ReaderT inner component -data XConf = - XConf { display :: Display - , rect :: Rectangle - , window :: Window - , fontListS :: [XFont] - , verticalOffsets :: [Int] - , iconS :: Map FilePath Bitmap - , config :: Config - } diff --git a/src/lib/Xmobar/X11/Window.hs b/src/lib/Xmobar/X11/Window.hs deleted file mode 100644 index 78f4b26..0000000 --- a/src/lib/Xmobar/X11/Window.hs +++ /dev/null @@ -1,229 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Window --- Copyright : (c) 2011-18 Jose A. Ortega Ruiz --- : (c) 2012 Jochen Keil --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Window manipulation functions --- ------------------------------------------------------------------------------ - -module Xmobar.X11.Window where - -import Prelude -import Control.Applicative ((<$>)) -import Control.Monad (when, unless) -import Graphics.X11.Xlib hiding (textExtents) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama -import Foreign.C.Types (CLong) - -import Data.Function (on) -import Data.List (maximumBy) -import Data.Maybe (fromMaybe) -import System.Posix.Process (getProcessID) - -import Xmobar.Config -import Xmobar.X11.XUtil - --- $window - --- | Creates a window with the attribute override_redirect set to True. --- Windows Managers should not touch this kind of windows. -newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window -newWindow dpy scr rw (Rectangle x y w h) o = do - let visual = defaultVisualOfScreen scr - attrmask = if o then cWOverrideRedirect else 0 - allocaSetWindowAttributes $ - \attributes -> do - set_override_redirect attributes o - createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) - inputOutput visual attrmask attributes - --- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) -createWin d fs c = do - let dflt = defaultScreen d - srs <- getScreenInfo d - rootw <- rootWindow d dflt - (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - r = setPosition c (position c) srs (fromIntegral ht) - win <- newWindow d (defaultScreenOfDisplay d) rootw r (overrideRedirect c) - setProperties c d win - setStruts r c d win srs - when (lowerOnStart c) $ lowerWindow d win - unless (hideOnStart c) $ showWindow r c d win - return (r,win) - --- | Updates the size and position of the window -repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle -repositionWin d win fs c = do - srs <- getScreenInfo d - (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - r = setPosition c (position c) srs (fromIntegral ht) - moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) - setStruts r c d win srs - return r - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -setPosition :: Config -> XPosition -> [Rectangle] -> Dimension -> Rectangle -setPosition c p rs ht = - case p' of - Top -> Rectangle rx ry rw h - TopP l r -> Rectangle (rx + fi l) ry (rw - fi l - fi r) h - TopW a i -> Rectangle (ax a i) ry (nw i) h - TopSize a i ch -> Rectangle (ax a i) ry (nw i) (mh ch) - Bottom -> Rectangle rx ny rw h - BottomW a i -> Rectangle (ax a i) ny (nw i) h - BottomP l r -> Rectangle (rx + fi l) ny (rw - fi l - fi r) h - BottomSize a i ch -> Rectangle (ax a i) (ny' ch) (nw i) (mh ch) - Static cx cy cw ch -> Rectangle (fi cx) (fi cy) (fi cw) (fi ch) - OnScreen _ p'' -> setPosition c p'' [scr] ht - where - (scr@(Rectangle rx ry rw rh), p') = - case p of OnScreen i x -> (fromMaybe (picker rs) $ safeIndex i rs, x) - _ -> (picker rs, p) - ny = ry + fi (rh - ht) - center i = rx + fi (div (remwid i) 2) - right i = rx + fi (remwid i) - remwid i = rw - pw (fi i) - ax L = const rx - ax R = right - ax C = center - pw i = rw * min 100 i `div` 100 - nw = fi . pw . fi - h = fi ht - mh h' = max (fi h') h - ny' h' = ry + fi (rh - mh h') - safeIndex i = lookup i . zip [0..] - picker = if pickBroadest c - then maximumBy (compare `on` rect_width) - else head - -setProperties :: Config -> Display -> Window -> IO () -setProperties c d w = do - let mkatom n = internAtom d n False - card <- mkatom "CARDINAL" - atom <- mkatom "ATOM" - - setTextProperty d w (wmClass c) wM_CLASS - setTextProperty d w (wmName c) wM_NAME - - wtype <- mkatom "_NET_WM_WINDOW_TYPE" - dock <- mkatom "_NET_WM_WINDOW_TYPE_DOCK" - changeProperty32 d w wtype atom propModeReplace [fi dock] - - when (allDesktops c) $ do - desktop <- mkatom "_NET_WM_DESKTOP" - changeProperty32 d w desktop card propModeReplace [0xffffffff] - - pid <- mkatom "_NET_WM_PID" - getProcessID >>= changeProperty32 d w pid card propModeReplace . return . fi - -setStruts' :: Display -> Window -> [Foreign.C.Types.CLong] -> IO () -setStruts' d w svs = do - let mkatom n = internAtom d n False - card <- mkatom "CARDINAL" - pstrut <- mkatom "_NET_WM_STRUT_PARTIAL" - strut <- mkatom "_NET_WM_STRUT" - changeProperty32 d w pstrut card propModeReplace svs - changeProperty32 d w strut card propModeReplace (take 4 svs) - -setStruts :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () -setStruts r c d w rs = do - let svs = map fi $ getStrutValues r (position c) (getRootWindowHeight rs) - setStruts' d w svs - -getRootWindowHeight :: [Rectangle] -> Int -getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) - where - getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) - -getStrutValues :: Rectangle -> XPosition -> Int -> [Int] -getStrutValues r@(Rectangle x y w h) p rwh = - case p of - OnScreen _ p' -> getStrutValues r p' rwh - Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomP _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - Static {} -> getStaticStrutValues p rwh - where st = fi y + fi h - sb = rwh - fi y - nx = fi x - nw = fi (x + fi w - 1) - --- get some reaonable strut values for static placement. -getStaticStrutValues :: XPosition -> Int -> [Int] -getStaticStrutValues (Static cx cy cw ch) rwh - -- if the yPos is in the top half of the screen, then assume a Top - -- placement, otherwise, it's a Bottom placement - | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] - | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] - where st = cy + ch - sb = rwh - cy - xs = cx -- a simple calculation for horizontal (x) placement - xe = xs + cw -getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - -drawBorder :: Border -> Int -> Display -> Drawable -> GC -> Pixel - -> Dimension -> Dimension -> IO () -drawBorder b lw d p gc c wi ht = case b of - NoBorder -> return () - TopB -> drawBorder (TopBM 0) lw d p gc c wi ht - BottomB -> drawBorder (BottomBM 0) lw d p gc c wi ht - FullB -> drawBorder (FullBM 0) lw d p gc c wi ht - TopBM m -> sf >> sla >> - drawLine d p gc 0 (fi m + boff) (fi wi) (fi m + boff) - BottomBM m -> let rw = fi ht - fi m + boff in - sf >> sla >> drawLine d p gc 0 rw (fi wi) rw - FullBM m -> let mp = fi m - pad = 2 * fi mp + fi lw - in sf >> sla >> - drawRectangle d p gc mp mp (wi - pad) (ht - pad) - where sf = setForeground d gc c - sla = setLineAttributes d gc (fi lw) lineSolid capNotLast joinMiter - boff = borderOffset b lw --- boff' = calcBorderOffset lw :: Int - -hideWindow :: Display -> Window -> IO () -hideWindow d w = do - setStruts' d w (replicate 12 0) - unmapWindow d w >> sync d False - -showWindow :: Rectangle -> Config -> Display -> Window -> IO () -showWindow r c d w = do - mapWindow d w - getScreenInfo d >>= setStruts r c d w - sync d False - -isMapped :: Display -> Window -> IO Bool -isMapped d w = ism <$> getWindowAttributes d w - where ism WindowAttributes { wa_map_state = wms } = wms /= waIsUnmapped - -borderOffset :: (Integral a) => Border -> Int -> a -borderOffset b lw = - case b of - BottomB -> negate boffs - BottomBM _ -> negate boffs - TopB -> boffs - TopBM _ -> boffs - _ -> 0 - where boffs = calcBorderOffset lw - -calcBorderOffset :: (Integral a) => Int -> a -calcBorderOffset = ceiling . (/2) . toDouble - where toDouble = fi :: (Integral a) => a -> Double diff --git a/src/lib/Xmobar/X11/XPMFile.hsc b/src/lib/Xmobar/X11/XPMFile.hsc deleted file mode 100644 index 2daffac..0000000 --- a/src/lib/Xmobar/X11/XPMFile.hsc +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : XPMFile --- Copyright : (C) 2014, 2018 Alexander Shabalin --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.X11.XPMFile(readXPMFile) where - -#if MIN_VERSION_mtl(2, 2, 1) -import Control.Monad.Except(MonadError(..)) -#else -import Control.Monad.Error(MonadError(..)) -#endif -import Control.Monad.Trans(MonadIO(..)) -import Graphics.X11.Xlib(Dimension, Display(..), Drawable, Pixmap) -import Foreign.C.String(CString, withCString) -import Foreign.C.Types(CInt(..), CLong) -import Foreign.Ptr(Ptr) -import Foreign.Marshal.Alloc(alloca, allocaBytes) -import Foreign.Storable(peek, peekByteOff, pokeByteOff) - -#include <X11/xpm.h> - -foreign import ccall "XpmReadFileToPixmap" - xpmReadFileToPixmap :: Display -> Drawable -> CString -> Ptr Pixmap -> Ptr Pixmap -> Ptr () -> IO CInt - -readXPMFile - :: (MonadError String m, MonadIO m) - => Display - -> Drawable - -> String - -> m (Dimension, Dimension, Pixmap, Maybe Pixmap) -readXPMFile display d filename = - toError $ withCString filename $ \c_filename -> - alloca $ \pixmap_return -> - alloca $ \shapemask_return -> - allocaBytes (#size XpmAttributes) $ \attributes -> do - (#poke XpmAttributes, valuemask) attributes ((#const XpmReturnAllocPixels) :: CLong) - res <- xpmReadFileToPixmap display d c_filename pixmap_return shapemask_return attributes - case res of - 0 -> do - width <- (#peek XpmAttributes, width) attributes - height <- (#peek XpmAttributes, height) attributes - pixmap <- peek pixmap_return - shapemask <- peek shapemask_return - return $ Right (width, height, pixmap, if shapemask == 0 then Nothing else Just shapemask) - 1 -> return $ Left "readXPMFile: XpmColorError" - -1 -> return $ Left "readXPMFile: XpmOpenFailed" - -2 -> return $ Left "readXPMFile: XpmFileInvalid" - -3 -> return $ Left "readXPMFile: XpmNoMemory" - -4 -> return $ Left "readXPMFile: XpmColorFailed" - _ -> return $ Left "readXPMFile: Unknown error" - where toError m = either throwError return =<< liftIO m diff --git a/src/lib/Xmobar/X11/XUtil.hs b/src/lib/Xmobar/X11/XUtil.hs deleted file mode 100644 index 6e9eb2b..0000000 --- a/src/lib/Xmobar/X11/XUtil.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : XUtil --- Copyright : (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz --- (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.X11.XUtil - ( XFont(..) - , initFont - , initCoreFont - , initUtf8Font - , textExtents - , textWidth - ) where - -import Control.Exception (SomeException, handle) -import Data.List -import Foreign -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import System.Mem.Weak ( addFinalizer ) - -#if defined XFT -import Xmobar.X11.MinXft -import Graphics.X11.Xrender -#else -import System.IO(hPutStrLn, stderr) -#endif - -data XFont = Core FontStruct - | Utf8 FontSet -#ifdef XFT - | Xft [AXftFont] -#endif - --- | When initFont gets a font name that starts with 'xft:' it switchs --- to the Xft backend Example: 'xft:Sans-10' -initFont :: Display -> String -> IO XFont -initFont d s = - let xftPrefix = "xft:" in - if xftPrefix `isPrefixOf` s then -#ifdef XFT - fmap Xft $ initXftFont d s -#else - do - hPutStrLn stderr $ "Warning: Xmobar must be built with " - ++ "the with_xft flag to support font '" ++ s - ++ ".' Falling back on default." - initFont d miscFixedFont -#endif - else - fmap Utf8 $ initUtf8Font d s - -miscFixedFont :: String -miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" - --- | Given a fontname returns the font structure. If the font name is --- not valid the default font will be loaded and returned. -initCoreFont :: Display -> String -> IO FontStruct -initCoreFont d s = do - f <- handle fallBack getIt - addFinalizer f (freeFont d f) - return f - where getIt = loadQueryFont d s - fallBack :: SomeException -> IO FontStruct - fallBack = const $ loadQueryFont d miscFixedFont - --- | Given a fontname returns the font structure. If the font name is --- not valid the default font will be loaded and returned. -initUtf8Font :: Display -> String -> IO FontSet -initUtf8Font d s = do - (_,_,f) <- handle fallBack getIt - addFinalizer f (freeFontSet d f) - return f - where getIt = createFontSet d s - fallBack :: SomeException -> IO ([String], String, FontSet) - fallBack = const $ createFontSet d miscFixedFont - -#ifdef XFT -initXftFont :: Display -> String -> IO [AXftFont] -initXftFont d s = do - let fontNames = wordsBy (== ',') (drop 4 s) - mapM openFont fontNames - where - openFont fontName = do - f <- openAXftFont d (defaultScreenOfDisplay d) fontName - addFinalizer f (closeAXftFont d f) - return f - wordsBy p str = case dropWhile p str of - "" -> [] - str' -> w : wordsBy p str'' - where - (w, str'') = break p str' -#endif - -textWidth :: Display -> XFont -> String -> IO Int -textWidth _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s -textWidth _ (Core fs) s = return $ fromIntegral $ Xlib.textWidth fs s -#ifdef XFT -textWidth dpy (Xft xftdraw) s = do - gi <- xftTxtExtents' dpy xftdraw s - return $ xglyphinfo_xOff gi -#endif - -textExtents :: XFont -> String -> IO (Int32,Int32) -textExtents (Core fs) s = do - let (_,a,d,_) = Xlib.textExtents fs s - return (a,d) -textExtents (Utf8 fs) s = do - let (_,rl) = wcTextExtents fs s - ascent = fromIntegral $ - (rect_y rl) - descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl) - return (ascent, descent) -#ifdef XFT -textExtents (Xft xftfonts) _ = do - ascent <- fromIntegral `fmap` xft_ascent' xftfonts - descent <- fromIntegral `fmap` xft_descent' xftfonts - return (ascent, descent) -#endif |