xmobar 0.9.2 → 0.10
raw patch · 19 files changed
+681/−153 lines, 19 filesdep ~base
Dependency ranges changed: base
Files
- Commands.hs +1/−1
- Config.hs +4/−2
- Main.hs +23/−16
- Parsers.hs +84/−6
- Plugins.hs +1/−1
- Plugins/EWMH.hs +264/−0
- Plugins/Monitors/Batt.hs +33/−23
- Plugins/Monitors/Common.hs +9/−3
- Plugins/Monitors/Mem.hs +1/−1
- Plugins/Monitors/Net.hs +22/−28
- Plugins/PipeReader.hs +1/−1
- Plugins/StdinReader.hs +2/−2
- Plugins/XMonadLog.hs +72/−0
- README +23/−0
- Runnable.hs +1/−2
- XUtil.hsc +64/−47
- Xmobar.hs +18/−12
- scripts/xmonadpropwrite.hs +41/−0
- xmobar.cabal +17/−8
Commands.hs view
@@ -67,7 +67,7 @@ hClose e case exit of ExitSuccess -> do- str <- catch (hGetLineSafe o) (\_ -> return "")+ str <- catch (hGetLineSafe o) (\(SomeException _) -> return "") closeHandles cb str _ -> do closeHandles
Config.hs view
@@ -6,7 +6,7 @@ -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) ----- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it> -- Stability : unstable -- Portability : unportable --@@ -30,6 +30,8 @@ import Plugins.PipeReader import Plugins.CommandReader import Plugins.StdinReader+import Plugins.XMonadLog+import Plugins.EWMH #ifdef INOTIFY import Plugins.Mail@@ -90,7 +92,7 @@ -- 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 :*: CommandReader :*: StdinReader :*:+runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: #ifdef INOTIFY Mail :*: #endif
Main.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Xmobar.Main -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) ----- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it> -- Stability : unstable -- Portability : unportable --@@ -24,6 +25,8 @@ import Config import XUtil +import Data.List (intercalate)+ import Paths_xmobar (version) import Data.IORef import Data.Version (showVersion)@@ -32,6 +35,7 @@ import System.Exit import System.Environment import System.Posix.Files+import Control.Monad (unless) -- $main @@ -41,10 +45,13 @@ d <- openDisplay "" args <- getArgs (o,file) <- getOpts args- c <- case file of- [cfgfile] -> readConfig cfgfile- _ -> readDefaultConfig+ (c,defaultings) <- case file of+ [cfgfile] -> readConfig cfgfile+ _ -> readDefaultConfig + unless (null defaultings) $ putStrLn $ "Fields missing from config defaulted: "+ ++ intercalate "," defaultings+ -- listen for ConfigureEvents on the root window, for xrandr support: rootw <- rootWindow d (defaultScreen d) selectInput d rootw structureNotifyMask@@ -57,25 +64,22 @@ vars <- mapM startCommand cl (r,w) <- createWin d fs conf eventLoop (XConf d r w fs conf) vars- releaseFont d fs -- | Reads the configuration files or quits with an error-readConfig :: FilePath -> IO Config+readConfig :: FilePath -> IO (Config,[String]) readConfig f = do- file <- fileExist f- s <- if file then readFileSafe f else error $ f ++ ": file not found!\n" ++ usage- case reads s of- [(conf,_)] -> return conf- [] -> error $ f ++ ": configuration file contains errors!\n" ++ usage- _ -> error ("Some problem occured. Aborting...")+ file <- io $ fileExist f+ s <- io $ if file then readFileSafe f else error $ f ++ ": file not found!\n" ++ usage+ either (\err -> error $ f ++ ": configuration file contains errors at:\n" ++ show err)+ return $ parseConfig s -- | Read default configuration file or load the default config-readDefaultConfig :: IO Config+readDefaultConfig :: IO (Config,[String]) readDefaultConfig = do- home <- getEnv "HOME"+ home <- io $ getEnv "HOME" let path = home ++ "/.xmobarrc"- f <- fileExist path- if f then readConfig path else return defaultConfig+ f <- io $ fileExist path+ if f then readConfig path else return (defaultConfig,[]) data Opts = Help | Version@@ -88,6 +92,7 @@ | Commands String | SepChar String | Template String+ | OnScr String deriving Show options :: [OptDescr Opts]@@ -103,6 +108,7 @@ , Option ['s' ] ["sepchar" ] (ReqArg SepChar "char" ) "The character used to separate commands in\nthe output template. Default '%'" , Option ['t' ] ["template" ] (ReqArg Template "template" ) "The output template" , Option ['c' ] ["commands" ] (ReqArg Commands "commands" ) "The list of commands to be executed"+ , Option ['x' ] ["screen" ] (ReqArg OnScr "screen" ) "On which X screen number to start" ] getOpts :: [String] -> IO ([Opts], [String])@@ -142,6 +148,7 @@ AlignSep s -> modifyIORef conf (\c -> c { alignSep = s }) >> go SepChar s -> modifyIORef conf (\c -> c { sepChar = s }) >> go Template s -> modifyIORef conf (\c -> c { template = s }) >> go+ OnScr n -> modifyIORef conf (\c -> c { position = OnScreen (read n) $ position c }) >> go Commands s -> case readCom s of Right x -> modifyIORef conf (\c -> c { commands = x }) >> go Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1)
Parsers.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Xmobar.Parsers -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) ----- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it> -- Stability : unstable -- Portability : unportable --@@ -15,13 +16,16 @@ module Parsers ( parseString , parseTemplate+ , parseConfig ) where import Config-import Commands import Runnable-import Text.ParserCombinators.Parsec+import Commands+ import qualified Data.Map as Map+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Perm -- | Runs the string parser parseString :: Config -> String -> IO [(String, String)]@@ -47,7 +51,7 @@ -- accepts only parsers with return type Char. notFollowedBy' :: Parser a -> Parser b -> Parser a notFollowedBy' p e = do x <- p- notFollowedBy (e >> return '*')+ notFollowedBy $ try (e >> return '*') return x -- | Parsers a string wrapped in a color specification.@@ -89,8 +93,8 @@ m = Map.fromList $ zip cl (commands c) return $ combine c m str --- | Given a finite "Map" and a parsed templatet produces the--- | resulting output string.+-- | 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@@ -99,3 +103,77 @@ allTillSep :: Config -> Parser String allTillSep = many . noneOf . sepChar++stripComments :: String -> String+stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines+ where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else ""+ strip m ('\\':xss) = case xss of+ '\\':xs -> '\\' : strip m xs+ _ -> strip m $ drop 1 xss+ strip m ('"':xs) = '"': strip (not m) xs+ strip m (x:xs) = x : strip m xs+ strip _ [] = []++-- | Parse the config, logging a list of fields that were missing and replaced+-- by the default definition.+parseConfig :: String -> Either ParseError (Config,[String])+parseConfig = runParser parseConf fields "Config" . stripComments+ where+ parseConf = do+ many space+ sepEndSpc ["Config","{"]+ x <- perms+ eof+ s <- getState+ return (x,s)++ perms = permute $ Config+ <$?> pFont <|?> pBgColor+ <|?> pFgColor <|?> pPosition+ <|?> pLowerOnStart <|?> pCommands+ <|?> pSepChar <|?> pAlignSep+ <|?> pTemplate++ fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep"+ , "template", "position", "lowerOnStart", "commands"]+ pFont = strField font "font"+ pBgColor = strField bgColor "bgColor"+ pFgColor = strField fgColor "fgColor"+ pSepChar = strField sepChar "sepChar"+ pAlignSep = strField alignSep "alignSep"+ pTemplate = strField template "template"++ pPosition = field position "position" $ tillFieldEnd >>= read' "position"+ pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart"+ pCommands = field commands "commands" $ readCommands++ staticPos = do string "Static"+ wrapSkip (string "{")+ p <- many (noneOf "}")+ wrapSkip (string "}")+ string ","+ return ("Static {" ++ p ++ "}")+ tillFieldEnd = staticPos <|> many (noneOf ",}\n\r")++ commandsEnd = wrapSkip (string "]") >> oneOf "},"+ readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]"++ strField e n = field e n . between (strDel "start" n) (strDel "end" n) . many $ noneOf "\"\n\r"+ strDel t n = char '"' <?> strErr t n+ strErr t n = "the " ++ t ++ " of the string field " ++ n ++ " - a double quote (\")."++ wrapSkip x = many space >> x >>= \r -> many space >> return r+ sepEndSpc = mapM_ (wrapSkip . try . string)+ fieldEnd = many $ space <|> oneOf ",}"+ field e n c = (,) (e defaultConfig) $+ updateState (filter (/= n)) >> sepEndSpc [n,"="] >>+ wrapSkip c >>= \r -> fieldEnd >> return r++ read' d s = case reads s of+ [(x, _)] -> return x+ _ -> fail $ "error reading the " ++ d ++ " field: " ++ s++commandsErr :: String+commandsErr = "commands: this usually means that a command could not be parsed.\n" +++ "The error could be located at the begining of the command which follows the offending one."+
Plugins.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) ----- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it> -- Stability : unstable -- Portability : unportable --
+ Plugins/EWMH.hs view
@@ -0,0 +1,264 @@+{-# OPTIONS_GHC -w #-}+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module : Plugins.EWMH+-- Copyright : (c) Spencer Janssen+-- License : BSD-style (see LICENSE)+--+-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- An experimental plugin to display EWMH pager information+--+-----------------------------------------------------------------------------++module Plugins.EWMH (EWMH(..)) where++import Control.Monad.State+import Control.Monad.Reader+import Graphics.X11 hiding (Modifier, Color)+import Graphics.X11.Xlib.Extras+import Plugins+#ifdef UTF8+#undef UTF8+import Codec.Binary.UTF8.String as UTF8+#define UTF8+#endif+import Foreign.C (CChar, CLong)+import XUtil (nextEvent')++import Data.List (intersperse, intercalate)++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+++data EWMH = EWMH | EWMHFMT Component deriving (Read, Show)++instance Exec EWMH where+ alias EWMH = "EWMH"++ start ew cb = allocaXEvent $ \ep -> execM $ do+ d <- asks display+ r <- asks root++ liftIO xSetErrorHandler++ liftIO $ selectInput d r propertyChangeMask+ handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers+ mapM_ ((=<< asks root) . snd) handlers'++ forever $ do+ liftIO . cb . fmtOf ew =<< get+ liftIO $ nextEvent' d ep+ e <- liftIO $ getEvent ep+ case e of+ PropertyEvent { ev_atom = a, ev_window = w } -> do+ 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, 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 (flip (,) 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 (map fst $ Map.toList dels)+ mapM_ listen (map fst $ Map.toList cl')+ mapM_ update (map 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
Plugins/Monitors/Batt.hs view
@@ -18,37 +18,47 @@ import Plugins.Monitors.Common import System.Posix.Files (fileExist) -data Batt = Batt Float+data Batt = Batt Float String | NA battConfig :: IO MConfig battConfig = mkMConfig "Batt: <left>" -- template- ["left"] -- available replacements+ ["left","status"] -- available replacements -file2batfile :: String -> (String, String)-file2batfile s = ("/proc/acpi/battery/"++ s ++ "/info", "/proc/acpi/battery/"++ s ++ "/state")+type File = (String, String) -readFileBatt :: (String, String) -> IO (B.ByteString, B.ByteString)-readFileBatt (i,s) =- do a <- rf i- b <- rf s- return (a,b)+file2batfile :: String -> (File, File)+file2batfile s = ( (s' ++ "/charge_full", s' ++ "/energy_full")+ , (s' ++ "/charge_now" , s' ++ "/energy_now" )+ )+ where s' = "/sys/class/power_supply/" ++ s++readFileBatt :: (File, File) -> IO (String, String, String)+readFileBatt (f,n) =+ do a <- rf f+ b <- rf n+ ac <- fileExist "/sys/class/power_supply/AC0/online"+ c <- if not ac+ then return []+ else do s <- B.unpack `fmap` catRead "/sys/class/power_supply/AC0/online"+ return $ if s == "1\n" then "<fc=green>On</fc>" else"<fc=red>Off</fc>"+ return (a,b,c) where rf file = do- f <- fileExist file- if f then B.readFile file else return B.empty+ fe <- fileExist (fst file)+ if fe+ then B.unpack `fmap` catRead (fst file)+ else do fe' <- fileExist (snd file)+ if fe'+ then B.unpack `fmap` catRead (snd file)+ else return [] -parseBATT :: [(String, String)] -> IO Batt+parseBATT :: [(File,File)] -> IO Batt parseBATT bfs =- do [(a0,b0),(a1,b1),(a2,b2)] <- mapM readFileBatt (take 3 $ bfs ++ repeat ("",""))- let sp p s = case stringParser p s of- [] -> 0- x -> read x- (f0, p0) = (sp (3,2) a0, sp (2,4) b0)- (f1, p1) = (sp (3,2) a1, sp (2,4) b1)- (f2, p2) = (sp (3,2) a2, sp (2,4) b2)- left = (p0 + p1 + p2) / (f0 + f1 + f2) --present / full- return $ if isNaN left then NA else Batt left+ do [(a0,b0,c0),(a1,b1,_),(a2,b2,_)] <- mapM readFileBatt (take 3 $ bfs ++ repeat (("",""),("","")))+ let read' s = if s == [] then 0 else read s+ left = (read' b0 + read' b1 + read' b2) / (read' a0 + read' a1 + read' a2) --present / full+ return $ if isNaN left then NA else Batt left c0 formatBatt :: Float -> Monitor [String] formatBatt x =@@ -63,6 +73,6 @@ runBatt' bfs _ = do c <- io $ parseBATT (map file2batfile bfs) case c of- Batt x -> do l <- formatBatt x- parseTemplate l+ Batt x s -> do l <- formatBatt x+ parseTemplate (l ++ [s]) NA -> return "N/A"
Plugins/Monitors/Common.hs view
@@ -43,6 +43,7 @@ -- * Threaded Actions -- $thread , doActionTwiceWithDelay+ , catRead ) where @@ -55,7 +56,8 @@ import Numeric import Text.ParserCombinators.Parsec import System.Console.GetOpt-import Control.Exception (handle)+import Control.Exception (SomeException,handle)+import System.Process(readProcess) import Plugins -- $monitor@@ -149,7 +151,8 @@ where go = do c <- conf let ac = doArgs args action- s <- handle (const $ return "error") $ runReaderT ac c+ he = return . (++) "error: " . show . flip asTypeOf (undefined::SomeException)+ s <- handle he $ runReaderT ac c cb s tenthSeconds r go@@ -262,7 +265,7 @@ floatToPercent :: Float -> String floatToPercent n = - showDigits 1 (n * 100) ++ "%"+ showDigits 0 (n * 100) ++ "%" stringParser :: Pos -> B.ByteString -> String stringParser (x,y) =@@ -306,3 +309,6 @@ do threadDelay d s <- action modifyMVar_ var (\_ -> return $! s)++catRead :: FilePath -> IO B.ByteString+catRead file = B.pack `fmap` readProcess "/bin/cat" [file] ""
Plugins/Monitors/Mem.hs view
@@ -37,7 +37,7 @@ formatMem :: [Float] -> Monitor [String] formatMem x =- do let f n = showDigits 1 n+ do let f n = showDigits 0 n mapM (showWithColors f) x runMem :: [String] -> Monitor String
Plugins/Monitors/Net.hs view
@@ -3,7 +3,7 @@ -- Module : Plugins.Monitors.Net -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE)--- +-- -- Maintainer : Andrea Rossato <andrea.rossato@unibz.it> -- Stability : unstable -- Portability : unportable@@ -31,42 +31,36 @@ "<dev>: <rx>|<tx>" -- template ["dev", "rx", "tx"] -- available replacements ---- takes two elements of a list given their indexes-getTwoElementsAt :: Int -> Int -> [a] -> [a]-getTwoElementsAt x y xs =- z : [zz]- where z = xs !! x- zz = xs !! y+-- Given a list of indexes, take the indexed elements from a list.+getNElements :: [Int] -> [a] -> [a]+getNElements ns as = map (as!!) ns --- split a list of strings returning a list with: 1. the first part of--- the split; 2. the second part of the split without the Char; 3. the--- rest of the list. For instance: +-- Split into words, with word boundaries indicated by the given predicate.+-- Drops delimiters. Duplicates 'Data.List.Split.wordsBy'. ----- > splitAtChar ':' ["lo:31174097","31174097"] +-- > map (wordsBy (`elem` " :")) ["lo:31174097 31174097", "eth0: 43598 88888"] ----- will become ["lo","31174097","31174097"]-splitAtChar :: Char -> [String] -> [String]-splitAtChar c xs =- first : (rest xs)- where rest = map $ \x -> if (c `elem` x) then (tail $ dropWhile (/= c) x) else x- first = head $ map (takeWhile (/= c)) . filter (\x -> (c `elem` x)) $ xs+-- will become @[["lo","31174097","31174097"], ["eth0","43598","88888"]]@+wordsBy :: (a -> Bool) -> [a] -> [[a]]+wordsBy f s = case dropWhile f s of+ [] -> []+ s' -> w : wordsBy f s'' where (w, s'') = break f s' -readNetDev :: [String] -> NetDev +readNetDev :: [String] -> NetDev readNetDev [] = NA readNetDev xs = ND (xs !! 0) (r (xs !! 1)) (r (xs !! 2)) where r s | s == "" = 0- | otherwise = (read s) / 1024+ | otherwise = read s / 1024 fileNET :: IO [NetDev]-fileNET = +fileNET = do f <- B.readFile "/proc/net/dev" return $ netParser f netParser :: B.ByteString -> [NetDev] netParser =- map readNetDev . map (splitAtChar ':') . map (getTwoElementsAt 0 8) . map (words . B.unpack) . drop 2 . B.lines+ map (readNetDev . getNElements [0,1,9] . wordsBy (`elem` " :") . B.unpack) . drop 2 . B.lines formatNet :: Float -> Monitor String formatNet d =@@ -75,25 +69,25 @@ printNet :: NetDev -> Monitor String printNet nd =- do case nd of+ case nd of ND d r t -> do rx <- formatNet r tx <- formatNet t parseTemplate [d,rx,tx] NA -> return "N/A" parseNET :: String -> IO [NetDev]-parseNET nd = +parseNET nd = do (a,b) <- doActionTwiceWithDelay interval fileNET- let netRate f da db = takeDigits 2 $ ((f db) - (f da)) * fromIntegral (1000000 `div` interval)- diffRate (da,db) = ND (netDev da) + let netRate f da db = takeDigits 2 $ (f db - f da) * fromIntegral (1000000 `div` interval)+ diffRate (da,db) = ND (netDev da) (netRate netRx da db) (netRate netTx da db) return $ filter (\d -> netDev d == nd) $ map diffRate $ zip a b runNet :: [String] -> Monitor String-runNet nd = +runNet nd = do pn <- io $ parseNET $ head nd n <- case pn of [x] -> return x- _ -> return $ NA+ _ -> return NA printNet n
Plugins/PipeReader.hs view
@@ -23,6 +23,6 @@ instance Exec PipeReader where alias (PipeReader _ a) = a start (PipeReader p _) cb = do- h <- openFile p ReadMode+ h <- openFile p ReadWriteMode forever (hGetLineSafe h >>= cb) where forever a = a >> forever a
Plugins/StdinReader.hs view
@@ -18,7 +18,7 @@ import System.Posix.Process import System.Exit import System.IO-import Control.Exception (catch)+import Control.Exception (SomeException(..),catch) import Plugins data StdinReader = StdinReader@@ -26,7 +26,7 @@ instance Exec StdinReader where start StdinReader cb = do- cb =<< catch (hGetLineSafe stdin) (\e -> do hPrint stderr e; return "")+ cb =<< catch (hGetLineSafe stdin) (\(SomeException e) -> do hPrint stderr e; return "") eof <- hIsEOF stdin if eof then exitImmediately ExitSuccess
+ Plugins/XMonadLog.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module : Plugins.StdinReader+-- Copyright : (c) Spencer Janssen+-- License : BSD-style (see LICENSE)+--+-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- A plugin to display information from _XMONAD_LOG, specified at+-- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs+--+-----------------------------------------------------------------------------++module Plugins.XMonadLog (XMonadLog(..)) where++import Control.Monad+import Graphics.X11+import Graphics.X11.Xlib.Extras+import Plugins+#ifdef UTF8+#undef UTF8+import Codec.Binary.UTF8.String as UTF8+#define UTF8+#endif+import Foreign.C (CChar)+import XUtil (nextEvent')+++data XMonadLog = XMonadLog | XPropertyLog String+ deriving (Read, Show)++instance Exec XMonadLog where+ alias XMonadLog = "XMonadLog"+ alias (XPropertyLog atom) = atom++ start x cb = do+ let atom = case x of+ XMonadLog -> "_XMONAD_LOG"+ XPropertyLog a -> a+ 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 . 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
README view
@@ -168,6 +168,27 @@ `template` : The output template. +### Running xmobar with i3status++[xmobar] can be used to display information gathered by [i3status], a+small program that gathers information and formats it suitable for+being displayed by the dzen2 status bar, wmii's status bar or xmobar's+StdinReader.++Since xmobar support has been added only recently you need to get the+git repository, and build it with the appropriate flags:++ git clone git://code.stapelberg.de/i3status++and then build it:++ cd i3status+ make EXTRA_CFLAGS="-DXMOBAR++Then you can run it with:++ ./i3status -c i3status.conf | xmobar -o -t "%StdinReader%" -c "[Run StdinReader]"+ ### Command Line Options [xmobar] can be either configured with a configuration file or with@@ -197,6 +218,7 @@ the output template. Default '%' -t template --template=template The output template -c commands --commands=commands The list of commands to be executed+ -x screen --screen=screen On which X screen number to start Mail bug reports and suggestions to <andrea.rossato@unibz.it> ### The Output Template@@ -577,3 +599,4 @@ [xmonad]: http://xmonad.org [utf8-string]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/utf8-string [X11-xft]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-xft+[i3status]: http://i3.zekjur.net/i3status/
Runnable.hs view
@@ -5,7 +5,7 @@ -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) ----- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it> -- Stability : unstable -- Portability : unportable --@@ -23,7 +23,6 @@ import Control.Monad import Text.Read-import Text.ParserCombinators.ReadPrec import Config (runnableTypes) import Commands
XUtil.hsc view
@@ -5,7 +5,7 @@ -- Copyright : (C) 2007 Andrea Rossato -- License : BSD3 ----- Maintainer : andrea.rossato@unibz.it+-- Maintainer : andrea.rossato@unitn.it -- Stability : unstable -- Portability : unportable --@@ -16,7 +16,6 @@ , initFont , initCoreFont , initUtf8Font- , releaseFont , textExtents , textWidth , printString@@ -28,20 +27,26 @@ , io , fi , withColors+ , DynPixel(..) ) where import Control.Concurrent-import Control.Monad import Control.Monad.Trans+import Data.IORef import Foreign import Graphics.X11.Xlib hiding (textExtents, textWidth) import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) import Graphics.X11.Xlib.Extras+import System.Mem.Weak ( addFinalizer ) import System.Posix.Types (Fd(..)) import System.IO #if defined XFT || defined UTF8+# if __GLASGOW_HASKELL__ < 612 import Foreign.C import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine)+# else+import qualified System.IO as UTF8 (readFile,hGetLine)+# endif #endif #if defined XFT import Data.List@@ -75,49 +80,46 @@ initFont :: Display ->String -> IO XFont initFont d s = #ifdef XFT- if xftPrefix `isPrefixOf` s then- do setupLocale- xftdraw <- xftFontOpen d (defaultScreenOfDisplay d) (drop (length xftPrefix) s)- return (Xft xftdraw)- else+ let xftPrefix = "xft:" in+ if xftPrefix `isPrefixOf` s then+ fmap Xft $ initXftFont d s+ else #endif-#ifdef UTF8- (setupLocale >> initUtf8Font d s >>= return . Utf8)+#if defined UTF8 || __GLASGOW_HASKELL__ >= 612+ fmap Utf8 $ initUtf8Font d s #else- (initCoreFont d s >>= return . Core)-#endif-#ifdef XFT- where xftPrefix = "xft:"+ fmap Core $ initCoreFont d s #endif -releaseFont :: Display -> XFont -> IO ()-#ifdef XFT-releaseFont d (Xft xftfont) = xftFontClose d xftfont-#endif-releaseFont d (Utf8 fs) = releaseUtf8Font d fs-releaseFont d (Core fs) = releaseCoreFont d fs- -- | 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 dpy s = catch (getIt dpy) (fallBack dpy)- where getIt d = loadQueryFont d s- fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"--releaseCoreFont :: Display -> FontStruct -> IO ()-releaseCoreFont d = freeFont d+initCoreFont d s = do+ f <- catch getIt fallBack+ addFinalizer f (freeFont d f)+ return f+ where getIt = loadQueryFont d s+ fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" -- | 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 dpy s = do- (_,_,fs) <- catch (getIt dpy) (fallBack dpy)- return fs- where getIt d = createFontSet d s- fallBack d = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"+initUtf8Font d s = do+ setupLocale+ (_,_,f) <- catch getIt fallBack+ addFinalizer f (freeFontSet d f)+ return f+ where getIt = createFontSet d s+ fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" -releaseUtf8Font :: Display -> FontSet -> IO ()-releaseUtf8Font d = freeFontSet d+#ifdef XFT+initXftFont :: Display -> String -> IO XftFont+initXftFont d s = do+ setupLocale+ f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s)+ addFinalizer f (xftFontClose d f)+ return f+#endif textWidth :: Display -> XFont -> String -> IO Int textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s@@ -169,12 +171,12 @@ gi <- xftTextExtents dpy font s setForeground dpy gc bcolor fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))- (y - fi a)+ (y - fi (a + d)) (fi $ xglyphinfo_xOff gi)- (fi $ a + d)+ (fi $ 4 + a + d) withXftDraw dpy drw visual colormap $ \draw -> withXftColorName dpy visual colormap fc $- \color -> xftDrawString draw color font x y s+ \color -> xftDrawString draw color font x (y - 2) s #endif data DynPixel = DynPixel { allocated :: Bool@@ -187,20 +189,32 @@ initColor dpy c = (initColor' dpy c) `catch` (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- (c', _) <- allocNamedColor dpy colormap c+ 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')- where colormap = defaultColormap dpy (defaultScreen dpy) withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a withColors d cs f = do ps <- mapM (io . initColor d) cs- r <- f $ map pixel ps- io $ freeColors d cmap (map pixel $ filter allocated ps) 0- return r- where- cmap = defaultColormap d (defaultScreen d)+ f $ map pixel ps -- | Creates a window with the attribute override_redirect set to True. -- Windows Managers should not touch this kind of windows.@@ -232,11 +246,14 @@ fi :: (Integral a, Num b) => a -> b fi = fromIntegral -#if defined XFT || defined UTF8+#if __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8) #include <locale.h> foreign import ccall unsafe "locale.h setlocale" setlocale :: CInt -> CString -> IO CString -setupLocale :: IO CString-setupLocale = withCString "" $ setlocale (#const LC_ALL)+setupLocale :: IO ()+setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return ()+# else+setupLocale :: IO ()+setupLocale = return () #endif
Xmobar.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Xmobar -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) ----- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>+-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it> -- Stability : unstable -- Portability : unportable --@@ -39,8 +40,8 @@ import Control.Concurrent.STM import Control.Exception hiding (handle) import Data.Bits-import Data.Char-+import Data.Maybe(fromMaybe)+import Data.Typeable (Typeable) import Config import Parsers@@ -68,12 +69,15 @@ runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc +data WakeUp = WakeUp deriving (Show,Typeable)+instance Exception WakeUp+ -- | The event loop eventLoop :: XConf -> [(Maybe ThreadId, TVar String)] -> IO () eventLoop xc@(XConf d _ w fs c) v = block $ do tv <- atomically $ newTVar [] t <- myThreadId- ct <- forkIO (checker t tv "" `catch` \_ -> return ())+ ct <- forkIO (checker t tv "" `catch` \(SomeException _) -> return ()) go tv ct where -- interrupt the drawing thread every time a var is updated@@ -83,14 +87,14 @@ guard (nv /= ov) writeTVar tvar nv return nv- throwDynTo t ()+ throwTo t WakeUp checker t tvar nval -- Continuously wait for a timer interrupt or an expose event go tv ct = do- catchDyn (unblock $ allocaXEvent $ \e ->- handle tv ct =<< (nextEvent' d e >> getEvent e))- (\() -> runX xc (updateWin tv) >> return ())+ catch (unblock $ allocaXEvent $ \e ->+ handle tv ct =<< (nextEvent' d e >> getEvent e))+ (\WakeUp -> runX xc (updateWin tv) >> return ()) go tv ct -- event hanlder@@ -151,11 +155,11 @@ BottomW R i -> (Rectangle (right i) ny (nw i) h , True) BottomW C i -> (Rectangle (center i) ny (nw i) h , True) Static cx cy cw ch -> (Rectangle (fi cx ) (fi cy) (fi cw) (fi ch), True)- OnScreen _ _ -> error "Nested OnScreen positions are not allowed"+ OnScreen _ p'' -> setPosition p'' [scr] ht where- (Rectangle rx ry rw rh, p') = case p of- OnScreen i x -> (rs !! i, x)- _ -> (head rs, p)+ (scr@(Rectangle rx ry rw rh), p') =+ case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x)+ _ -> (head rs, p) ny = ry + fi (rh - ht) center i = rx + (fi $ div (remwid i) 2) right i = rx + (fi $ remwid i)@@ -163,6 +167,8 @@ pw i = rw * (min 100 i) `div` 100 nw = fi . pw . fi h = fi ht++ safeIndex i = lookup i . zip [0..] setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () setProperties r c d w srs = do
+ scripts/xmonadpropwrite.hs view
@@ -0,0 +1,41 @@+-- Copyright Spencer Janssen <spencerjanssen@gmail.com>+-- Tomas Janousek <tomi@nomi.cz>+-- BSD3 (see LICENSE)+--+-- Reads from standard input and writes to an X propery on root window.+-- To be used with XPropertyLog:+-- Add it to commands:+-- Run XPropertyLog "_XMONAD_LOG_CUSTOM"+-- Add it to the template:+-- template = "... %_XMONAD_LOG_CUSTOM% ..."+-- Run:+-- $ blah blah | xmonadpropwrite _XMONAD_LOG_CUSTOM++import Control.Monad+import Graphics.X11+import Graphics.X11.Xlib.Extras+import qualified Data.ByteString as B+import Foreign.C (CChar)+import System.IO+import System.Environment++main = do+ atom <- flip fmap getArgs $ \args -> case args of+ [a] -> a+ _ -> "_XMONAD_LOG"++ d <- openDisplay ""+ xlog <- internAtom d atom False+ ustring <- internAtom d "UTF8_STRING" False++ root <- rootWindow d (defaultScreen d)++ forever $ do+ msg <- B.getLine+ changeProperty8 d root xlog ustring propModeReplace (encodeCChar msg)+ sync d True++ return ()++encodeCChar :: B.ByteString -> [CChar]+encodeCChar = map fromIntegral . B.unpack
xmobar.cabal view
@@ -1,5 +1,5 @@ name: xmobar-version: 0.9.2+version: 0.10 homepage: http://code.haskell.org/~arossato/xmobar synopsis: A Minimalistic Text Based Status Bar description: Xmobar is a minimalistic text based status bar.@@ -12,41 +12,50 @@ license-file: LICENSE author: Andrea Rossato maintainer: andrea.rossato@unitn.it-cabal-version: >= 1.2+cabal-version: >= 1.6 build-type: Simple +data-files: xmobar.config-sample+ flag small_base description: Choose the new smaller, split-up base package. flag with_xft description: Use Xft to render text. UTF-8 support included.+ default: False flag with_utf8 description: With UTF-8 support. flag with_inotify description: inotify support (modern Linux only). Required for the Mail plugin.+ default: False executable xmobar main-is: Main.hs other-Modules: Xmobar, Config, Parsers, Commands, XUtil, Runnable, Plugins- ghc-options: -funbox-strict-fields -Wall ghc-prof-options: -prof -auto-all + if true+ ghc-options: -funbox-strict-fields -Wall+ if impl (ghc == 6.10.1) && arch (x86_64)- ghc-options: -O0+ ghc-options: -O0 + if impl (ghc >= 6.12.1)+ ghc-options: -fno-warn-unused-do-bind+ if flag(small_base)- build-depends: base >= 3, base < 4, containers, process, old-time, old-locale, bytestring, directory+ build-depends: base == 4.*, containers, process, old-time, old-locale, bytestring, directory else- build-depends: base < 3+ build-depends: base < 3 if flag(with_xft) build-depends: utf8-string, X11-xft >= 0.2 cpp-options: -DXFT - if flag(with_utf8)+ if flag(with_utf8) && impl (ghc < 6.12.1) build-depends: utf8-string cpp-options: -DUTF8 @@ -54,4 +63,4 @@ build-depends: hinotify cpp-options: -DINOTIFY - build-depends: X11>=1.3.0, mtl, unix, parsec, filepath, stm+ build-depends: X11>=1.3.0, mtl, unix, parsec, filepath, stm